[RFC/PATCH] New Lintian::Output module
A patch series to bundle all the output logic of lintian into
modules and to make it easier to define new output formats.
Comments welcome.
Gruesse,
--
Frank Lichtenheld <djpig@debian.org>
www: http://www.djpig.de/
>From 86dd77bd3dff8cc9d0399875aa0db3e7a201187c Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Fri, 19 Sep 2008 13:31:44 +0200
Subject: [PATCH] Lintian::Output: New module for bundeling lintian output functionality
Create a object oriented interface but use a default object if called
without an object.
The methods are designed to be overridable to allow easy generation of
alternative output formats.
---
lib/Lintian/Output.pm | 164 +++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 164 insertions(+), 0 deletions(-)
create mode 100644 lib/Lintian/Output.pm
diff --git a/lib/Lintian/Output.pm b/lib/Lintian/Output.pm
new file mode 100644
index 0000000..32827c1
--- /dev/null
+++ b/lib/Lintian/Output.pm
@@ -0,0 +1,164 @@
+# Copyright (C) 2008 Frank Lichtenheld <frank@lichtenheld.de>
+#
+# 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., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Output;
+
+use strict;
+use warnings;
+
+use v5.8.0; # for PerlIO
+
+# support for ANSI color output via colored()
+use Term::ANSIColor ();
+use Tags ();
+
+use base qw(Class::Accessor Exporter);
+Lintian::Output->mk_accessors(qw(verbose debug quiet color colors stdout stderr));
+
+our @EXPORT = ();
+our %EXPORT_TAGS = ( messages => [qw(msg v_msg warning debug_msg delimiter)],
+ util => [qw(_global_or_object)]);
+our @EXPORT_OK = (@{$EXPORT_TAGS{messages}},
+ @{$EXPORT_TAGS{util}},
+ 'string');
+
+# for the non-OO interface
+our $GLOBAL = new Lintian::Output;
+
+my %default_colors = ( 'E' => 'red' , 'W' => 'yellow' , 'I' => 'cyan' );
+
+sub new {
+ my ($class, %options) = @_;
+ my $self = { %options };
+
+ bless($self, $class);
+
+ $self->stdout(\*STDOUT);
+ $self->stderr(\*STDERR);
+ $self->colors({%default_colors});
+
+ return $self;
+}
+
+sub debug_msg {
+ my ($self, $level, @args) = _global_or_object(@_);
+
+ return unless $self->debug && ($self->debug >= $level);
+
+ $self->_message(@args);
+}
+
+sub warning {
+ my ($self, @args) = _global_or_object(@_);
+
+ return if $self->quiet;
+ $self->_warning(@args);
+}
+
+sub v_msg {
+ my ($self, @args) = _global_or_object(@_);
+
+ return unless $self->verbose;
+ $self->_message(@args);
+}
+
+sub msg {
+ my ($self, @args) = _global_or_object(@_);
+
+ return if $self->quiet;
+ $self->_message(@args);
+}
+
+sub string {
+ my ($self, $lead, @args) = _global_or_object(@_);
+
+ my $output = '';
+ if (@args) {
+ foreach (@args) {
+ $output .= $lead.': '.$_."\n";
+ }
+ } elsif ($lead) {
+ $output .= $lead.".\n";
+ }
+
+ return $output;
+}
+
+sub print_tag {
+ my ( $self, $pkg_info, $tag_info, $information ) = _global_or_object(@_);
+
+ my $extra = '';
+ $extra = " @$information" if @$information;
+ $extra = '' if $extra eq ' ';
+ my $code = Tags::get_tag_code($tag_info);
+ my $tag_color = $self->{colors}{$code};
+ $code = 'X' if exists $tag_info->{experimental};
+ $code = 'O' if $tag_info->{overridden}{override};
+ my $type = '';
+ $type = " $pkg_info->{type}" if $pkg_info->{type} ne 'binary';
+
+ my $tag;
+ if ($self->color eq 'always'
+ || ($self->color eq 'auto' && -t $self->stdout)) {
+ $tag .= Term::ANSIColor::colored($tag_info->{tag}, $tag_color);
+ } else {
+ $tag .= $tag_info->{tag};
+ }
+
+ $self->_print('', "$code: $pkg_info->{pkg}$type", "$tag$extra");
+}
+
+sub delimiter {
+ my ($self) = _global_or_object(@_);
+
+ return $self->_delimiter;
+}
+
+sub _delimiter {
+ return '----';
+}
+
+sub _message {
+ my ($self, @args) = @_;
+
+ $self->_print('', 'N', @args);
+}
+
+sub _warning {
+ my ($self, @args) = @_;
+
+ $self->_print($self->stderr, 'warning', @args);
+}
+
+sub _print {
+ my ($self, $stream, $lead, @args) = @_;
+ $stream ||= $self->stdout;
+
+ my $output = $self->string($lead, @args);
+ print {$stream} $output;
+}
+
+sub _global_or_object {
+ if (ref($_[0]) and $_[0]->isa('Lintian::Output')) {
+ return @_;
+ } else {
+ return ($Lintian::Output::GLOBAL, @_);
+ }
+}
+
+1;
--
1.6.0.1
>From 76e0e70421828c154929c06c5242c79507a01d1f Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Fri, 19 Sep 2008 14:16:32 +0200
Subject: [PATCH] Begin conversion to Lintian::Output
This commit includes only the safe changes that do not actually change the
output. Note that this commit on its own will not work, I just wanted to
separate the safe changes from the ones that do change something.
---
frontend/lintian | 156 +++++++++++++++++++++++++----------------------------
lib/Lab.pm | 27 ++++------
lib/Util.pm | 10 ++--
3 files changed, 90 insertions(+), 103 deletions(-)
diff --git a/frontend/lintian b/frontend/lintian
index 3e3d9e3..9ebefdc 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -42,10 +42,8 @@ my $LAB_FORMAT = 8; #Lab format Version Number
# they were set via commandline or environment variables
my $pkg_mode = 'a'; # auto -- automatically search for
# binary and source pkgs
-use vars qw($verbose);
-$verbose = 0; #flag for -v|--verbose switch
-our $debug = 0; #flag for -d|--debug switch
-our $quiet = 0; #flag for -q|--quiet switch
+my $verbose = 0; #flag for -v|--verbose switch
+my $quiet = 0; #flag for -q|--quiet switch
my @debug;
my $check_everything = 0; #flag for -a|--all switch
my $lintian_info = 0; #flag for -i|--info switch
@@ -397,10 +395,6 @@ if (defined $LINTIAN_ROOT) {
$LINTIAN_ROOT = '/usr/share/lintian';
}
-$debug = $#debug + 1;
-$verbose = 1 if $debug;
-$::verbose = $verbose; # that's $main::verbose
-
# keep-lab implies unpack-level=2 unless explicetly
# given otherwise
if ($keep_lab and not defined $unpack_level) {
@@ -558,22 +552,10 @@ foreach (('ROOT', 'CFG', VARS)) {
}
}
+my $debug = $#debug + 1;
+$verbose = 1 if $debug;
$ENV{'LINTIAN_DEBUG'} = $debug;
-# Print Debug banner, now that we're finished determining
-# the values
-if ($debug) {
- print "N: $BANNER\n";
- print "N: Lintian root directory: $LINTIAN_ROOT\n";
- print "N: Configuration file: $LINTIAN_CFG\n";
- print "N: Laboratory: $LINTIAN_LAB\n";
- print "N: Archive directory: $LINTIAN_ARCHIVEDIR\n";
- print "N: Distribution: $LINTIAN_DIST\n";
- print "N: Default unpack level: $LINTIAN_UNPACK_LEVEL\n";
- print "N: Architecture: $LINTIAN_ARCH\n";
- print "N: ----\n";
-}
-
# }}}
# {{{ Loading lintian's own libraries (now LINTIAN_ROOT is known)
@@ -592,10 +574,8 @@ require Tags;
import Tags;
require Lintian::Schedule;
-
-my @l_secs = read_dpkg_control("$LINTIAN_ROOT/checks/lintian.desc");
-shift(@l_secs);
-map { $_->{'script'} = 'lintian'; Tags::add_tag($_) } @l_secs;
+require Lintian::Output;
+import Lintian::Output qw(:messages);
no warnings 'once';
if (defined $experimental_output_opts) {
@@ -615,6 +595,29 @@ if (defined $experimental_output_opts) {
}
}
+$Lintian::Output::GLOBAL->verbose($verbose);
+$Lintian::Output::GLOBAL->debug($debug);
+$Lintian::Output::GLOBAL->quiet($quiet);
+$Lintian::Output::GLOBAL->color($color);
+
+# Print Debug banner, now that we're finished determining
+# the values and have Lintian::Output available
+debug_msg(1,
+ $BANNER,
+ "Lintian root directory: $LINTIAN_ROOT",
+ "Configuration file: $LINTIAN_CFG",
+ "Laboratory: $LINTIAN_LAB",
+ "Archive directory: $LINTIAN_ARCHIVEDIR",
+ "Distribution: $LINTIAN_DIST",
+ "Default unpack level: $LINTIAN_UNPACK_LEVEL",
+ "Architecture: $LINTIAN_ARCH",
+ delimiter(),
+ );
+
+my @l_secs = read_dpkg_control("$LINTIAN_ROOT/checks/lintian.desc");
+shift(@l_secs);
+map { $_->{'script'} = 'lintian'; Tags::add_tag($_) } @l_secs;
+
$Tags::show_experimental = $display_experimentaltags;
$Tags::show_overrides = $show_overrides;
%Tags::display_level = %display_level;
@@ -645,7 +648,7 @@ $LAB = new Lab( $LINTIAN_LAB, $LINTIAN_DIST );
# Process -S option
if ($action eq 'setup-lab') {
if ($#ARGV+1 > 0) {
- print STDERR "warning: ignoring additional command line arguments\n";
+ warning("ignoring additional command line arguments");
}
$LAB->setup_static()
@@ -657,7 +660,7 @@ if ($action eq 'setup-lab') {
# Process -R option
} elsif ($action eq 'remove-lab') {
if ($#ARGV+1 > 0) {
- print STDERR "warning: ignoring additional command line arguments\n";
+ warning("ignoring additional command line arguments");
}
$LAB->delete_static()
@@ -688,7 +691,7 @@ $LINTIAN_LAB = $LAB->{dir};
# be moved up
if ($lintian_info) {
open(OUTPUT_PIPE, '|-', $lintian_info_cmd) or fail("cannot open output pipe to $lintian_info_cmd: $!");
- select OUTPUT_PIPE;
+ $Lintian::Output::GLOBAL->stdout(\*OUTPUT_PIPE);
}
# Close the OUTPUT_PIPE in an END block so that we can ensure that
@@ -696,10 +699,10 @@ if ($lintian_info) {
# lintian-info after lintian exits, which can confuse the shell output.
END {
if ($lintian_info) {
- my $status = $?;
- close OUTPUT_PIPE;
- select STDOUT;
- $? = $status;
+ my $status = $?;
+ close OUTPUT_PIPE;
+ $Lintian::Output::GLOBAL->stdout(\*STDOUT);
+ $? = $status;
}
}
# }}}
@@ -719,28 +722,28 @@ while (my $arg = shift) {
# .deb file?
if ($arg =~ /\.deb$/) {
$schedule->add_deb('b', $arg)
- or warn "$arg is a zero-byte file, skipping\n";
+ or warning("$arg is a zero-byte file, skipping");
}
# .udeb file?
elsif ($arg =~ /\.udeb$/) {
$schedule->add_deb('u', $arg)
- or warn "$arg is a zero-byte file, skipping\n";
+ or warning("$arg is a zero-byte file, skipping");
}
# .dsc file?
elsif ($arg =~ /\.dsc$/) {
$schedule->add_dsc($arg)
- or warn "$arg is a zero-byte file, skipping\n";
+ or warning("$arg is a zero-byte file, skipping");
}
# .changes file?
elsif ($arg =~ /\.changes$/) {
# get directory and filename part of $arg
my ($arg_dir, $arg_name) = $arg =~ m,(.*)/([^/]+)$,;
- print "N: Processing changes file $arg_name ...\n" if $verbose;
+ v_msg("Processing changes file $arg_name ...");
my ($data) = read_dpkg_control($arg);
if (not defined $data) {
- warn "$arg is a zero-byte file, skipping\n";
+ warning("$arg is a zero-byte file, skipping");
next;
}
@@ -964,7 +967,7 @@ while (my $arg = shift) {
}
if (not $check_everything and not $packages_file and not $schedule->count) {
- print "N: No packages selected.\n" if $verbose;
+ v_msg("No packages selected.");
exit $exit_code;
}
# }}}
@@ -990,7 +993,7 @@ for my $f (readdir COLLDIR) {
next if $f =~ /^\./;
next unless $f =~ /\.desc$/;
- print "N: Reading collector description file $f ...\n" if $debug >= 2;
+ debug_msg(2, "Reading collector description file $f ...");
my @secs = read_dpkg_control("$LINTIAN_ROOT/collection/$f");
my $script;
($#secs+1 == 1)
@@ -1035,14 +1038,10 @@ for my $f (readdir COLLDIR) {
delete $secs[0]->{'author'};
for (keys %{$secs[0]}) {
- print STDERR "warning: unused tag $_ in description file $f\n";
+ warning("unused tag $_ in description file $f");
}
- if ($debug >= 2) {
- for (sort keys %$p) {
- print "N: $_: $p->{$_}\n";
- }
- }
+ debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
}
closedir(COLLDIR);
@@ -1057,7 +1056,7 @@ opendir(CHECKDIR, "$LINTIAN_ROOT/checks")
for my $f (readdir CHECKDIR) {
next if $f =~ /^\./;
next unless $f =~ /\.desc$/;
- print "N: Reading checker description file $f ...\n" if $debug >= 2;
+ debug_msg(2, "Reading checker description file $f ...");
my @secs = read_dpkg_control("$LINTIAN_ROOT/checks/$f");
my $script;
@@ -1104,14 +1103,10 @@ for my $f (readdir CHECKDIR) {
delete $secs[0]->{'author'};
for (keys %{$secs[0]}) {
- print STDERR "warning: unused tag $_ in description file $f\n";
+ warning("unused tag $_ in description file $f");
}
- if ($debug >= 2) {
- for (sort keys %$p) {
- print "N: $_: $p->{$_}\n";
- }
- }
+ debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
shift(@secs);
$p->{'requested-tags'} = 0;
@@ -1247,7 +1242,7 @@ if ($check_everything) {
# package list still empty?
unless ($schedule->count) {
- print STDERR "warning: no packages found in distribution directory\n";
+ warning("no packages found in distribution directory");
}
} elsif ($packages_file) { # process all packages listed in packages file?
$schedule->add_pkg_list($packages_file);
@@ -1256,20 +1251,20 @@ if ($check_everything) {
# {{{ Some silent exit
unless ($schedule->count) {
- print "N: No packages selected.\n" if $verbose;
+ v_msg("No packages selected.");
exit 0;
}
# }}}
# {{{ Okay, now really processing the packages in one huge loop
$unpack_infos{ "override-file" } = 1 unless $no_override;
-printf "N: Processing %d packages...\n", $schedule->count if $verbose;
-if ($debug) {
- print "N: Selected action: $action\n";
- print "N: Requested unpack level: $unpack_level\n";
- printf "N: Requested data to collect: %s\n",join(',',keys %unpack_infos);
- printf "N: Selected checks: %s\n",join(',',keys %checks);
-}
+v_msg(sprintf("Processing %d packages...", $schedule->count));
+debug_msg(1,
+ "Selected action: $action",
+ "Requested unpack level: $unpack_level",
+ sprintf("Requested data to collect: %s", join(',',keys %unpack_infos)),
+ sprintf("Selected checks: %s", join(',',keys %checks)),
+ );
require Checker;
require Lintian::Collect;
@@ -1282,10 +1277,7 @@ foreach my $pkg_info ($schedule->get_all) {
my $long_type = ($type eq 'b' ? 'binary' :
($type eq 's' ? 'source' : 'udeb' ));
- if ($verbose) {
- print "N: ----\n";
- print "N: Processing $long_type package $pkg (version $ver) ...\n";
- }
+ v_msg(delimiter(), "Processing $long_type package $pkg (version $ver) ...");
Tags::set_pkg( $file, $pkg, $ver, $arch, $long_type );
# determine base directory
@@ -1293,7 +1285,7 @@ foreach my $pkg_info ($schedule->get_all) {
unless ($base =~ m,^/,) {
$base = "$cwd/$base";
}
- print "N: Base directory in lab: $base\n" if $debug;
+ debug_msg(1, "Base directory in lab: $base");
my $act_unpack_level = 0;
@@ -1307,7 +1299,7 @@ foreach my $pkg_info ($schedule->get_all) {
# lintian status file exists?
unless (-f "$base/.lintian-status") {
- print "N: No lintian status file found (removing old directory in lab)\n" if $verbose;
+ v_msg("No lintian status file found (removing old directory in lab)");
$remove_basedir = 1;
goto REMOVE_BASEDIR;
}
@@ -1316,21 +1308,21 @@ foreach my $pkg_info ($schedule->get_all) {
my $data;
eval { ($data) = read_dpkg_control("$base/.lintian-status"); };
if ($@) { # error!
- print "N: $@\n" if $verbose;
+ v_msg($@);
$remove_basedir = 1;
goto REMOVE_BASEDIR;
}
# compatible lintian version?
if (not exists $data->{'lab-format'} or ($data->{'lab-format'} < $LAB_FORMAT)) {
- print "N: Lab directory was created by incompatible lintian version\n" if $verbose;
+ v_msg("Lab directory was created by incompatible lintian version");
$remove_basedir = 1;
goto REMOVE_BASEDIR;
}
# version up to date?
if (not exists $data->{'version'} or ($data->{'version'} ne $ver)) {
- print "N: Removing package in lab (newer version exists) ...\n" if $debug;
+ debug_msg(1, "Removing package in lab (newer version exists) ...");
$remove_basedir = 1;
goto REMOVE_BASEDIR;
}
@@ -1353,14 +1345,14 @@ foreach my $pkg_info ($schedule->get_all) {
$timestamp = $stat[9];
}
if ((not defined $timestamp) or (not exists $data->{'timestamp'}) or ($data->{'timestamp'} != $timestamp)) {
- print "N: Removing package in lab (package has been changed) ...\n" if $debug;
+ debug_msg(1, "Removing package in lab (package has been changed) ...");
$remove_basedir = 1;
goto REMOVE_BASEDIR;
}
REMOVE_BASEDIR:
if ($remove_basedir) {
- print "N: Removing $pkg\n" if $verbose;
+ v_msg("Removing $pkg");
unless (remove_pkg($base)) {
print "N: Skipping $action of $long_type package $pkg\n";
$exit_code = 2;
@@ -1409,7 +1401,7 @@ foreach my $pkg_info ($schedule->get_all) {
# collect info
remove_status_file($base);
- print "N: Collecting info: $coll ...\n" if $debug;
+ debug_msg(1, "Collecting info: $coll ...");
if (spawn("$LINTIAN_ROOT/collection/$ci->{'script'}", $pkg, $long_type) != 0) {
print STDERR "internal error: collect info $coll about package $pkg: $?\n";
print "N: Skipping $action of $long_type package $pkg\n";
@@ -1556,7 +1548,7 @@ foreach my $pkg_info ($schedule->get_all) {
close(STATUS);
}
}
-if ($action eq 'check' and not $quiet and not $no_override and not $show_overrides) {
+if ($action eq 'check' and not $no_override and not $show_overrides) {
my $errors = $overrides{errors} || 0;
my $warnings = $overrides{warnings} || 0;
my $info = $overrides{info} || 0;
@@ -1575,7 +1567,7 @@ if ($action eq 'check' and not $quiet and not $no_override and not $show_overrid
if ($info) {
push (@output, "$info info");
}
- print "N: $total (", join (', ', @output), ")\n";
+ msg("$total (". join (', ', @output). ")");
}
}
@@ -1588,7 +1580,7 @@ exit $exit_code;
sub unpack_pkg {
my ($type,$base,$file,$cur_level,$new_level) = @_;
- printf("N: Current unpack level is %d\n",$cur_level) if $debug;
+ debug_msg(1, sprintf("Current unpack level is %d",$cur_level));
return $cur_level if $cur_level == $new_level;
@@ -1603,7 +1595,7 @@ sub unpack_pkg {
if ( ($new_level >= 1) and
(not defined ($cur_level) or ($cur_level < 1)) ) {
# create new directory
- print "N: Unpacking package to level 1 ...\n" if $debug;
+ debug_msg(1, "Unpacking package to level 1 ...");
if (($type eq 'b') || ($type eq 'u')) {
spawn("$LINTIAN_ROOT/unpack/unpack-binpkg-l1", $base, $file) == 0
or return -1;
@@ -1617,12 +1609,12 @@ sub unpack_pkg {
if ( ($new_level >= 2) and
(not defined ($cur_level) or ($cur_level < 2)) ) {
# unpack package contents
- print "N: Unpacking package to level 2 ...\n" if $debug;
+ debug_msg(1, "Unpacking package to level 2 ...");
if (($type eq 'b') || ($type eq 'u')) {
spawn("$LINTIAN_ROOT/unpack/unpack-binpkg-l2", $base) == 0
or return -1;
} else {
- print "N: $LINTIAN_ROOT/unpack/unpack-srcpkg-l2 $base\n" if $debug;
+ debug_msg(1, "$LINTIAN_ROOT/unpack/unpack-srcpkg-l2 $base");
spawn("$LINTIAN_ROOT/unpack/unpack-srcpkg-l2", $base) == 0
or return -1;
}
@@ -1650,7 +1642,7 @@ sub clean_pkg {
remove_status_file($base);
# remove unpacked/ directory
- print "N: Decreasing unpack level to 1 (removing files) ...\n" if $debug;
+ debug_msg(1, "Decreasing unpack level to 1 (removing files) ...");
if ( -l "$base/unpacked" ) {
spawn('rm', '-rf', '--', "$base/".readlink( "$base/unpacked" )) == 0
or return -1;
@@ -1669,7 +1661,7 @@ sub clean_pkg {
sub remove_pkg {
my ($base) = @_;
- print "N: Removing package in lab ...\n" if $debug;
+ debug_msg(1, "Removing package in lab ...");
if (spawn('rm', '-rf', '--', $base) != 0) {
print STDERR "error: cannot remove directory $base: $!\n";
return 0;
diff --git a/lib/Lab.pm b/lib/Lab.pm
index 63e20dc..a111baf 100644
--- a/lib/Lab.pm
+++ b/lib/Lab.pm
@@ -24,20 +24,15 @@ use strict;
use Pipeline;
use Util;
+use Lintian::Output qw(:messages);
use File::Temp;
# Quiet "Name "main::LINTIAN_ROOT" used only once"
-# The variables comes from 'lintian'
-() = ($main::LINTIAN_ROOT, $main::verbose, $main::debug);
+() = ($main::LINTIAN_ROOT);
my $LINTIAN_ROOT = $main::LINTIAN_ROOT;
-# Can also be more precise later on (only verbose with lab actions) but for
-# now this will do --Jeroen
-my $verbose = $main::verbose;
-my $debug = $main::debug;
-
sub new {
my ( $class, $dir, $dist ) = @_;
@@ -90,7 +85,7 @@ sub setup_static {
my ( $self ) = @_;
unless ( $self->{mode} eq 'static' and $self->{dir} ) {
- print STDERR "no laboratory specified (need to define LINTIAN_LAB)";
+ warning("no laboratory specified (need to define LINTIAN_LAB)");
return 0;
}
@@ -103,7 +98,7 @@ sub setup_force {
return unless $dir;
- print "N: Setting up lab in $dir ...\n" if $verbose;
+ v_msg("Setting up lab in $dir ...");
# create lab directory
# (Note, that the mode 0777 is reduced by the current umask.)
@@ -145,7 +140,7 @@ sub populate_with_dist {
print STDERR "spawning list-binpkg, list-udebpkg and list-srcpkg since LINTIAN_DIST=$dist\n" if ($debug >= 2);
- my $v = $verbose ? '-v' : '';
+ my $v = $Lintian::Output::GLOBAL->verbose ? '-v' : '';
spawn("$LINTIAN_ROOT/unpack/list-binpkg",
"$self->{dir}/info/binary-packages", $v) == 0
@@ -164,7 +159,7 @@ sub delete_static {
my ( $self ) = @_;
unless ( $self->{mode} eq 'static' and $self->{dir} ) {
- print STDERR "warning: no laboratory specified (need to define LINTIAN_LAB)";
+ warning("no laboratory specified (need to define LINTIAN_LAB)");
return 0;
}
@@ -185,7 +180,7 @@ sub delete_force {
return 0 unless $self->{dir};
- print "N: Removing $self->{dir} ...\n" if $verbose;
+ v_msg("Removing $self->{dir} ...");
# since we will chdir in a moment, make the path of the lab absolute
unless ( $self->{dir} =~ m,^/, ) {
@@ -200,7 +195,7 @@ sub delete_force {
# does the lab exist?
unless (-d $self->{dir}) {
# no.
- print STDERR "warning: cannot remove lab in directory $self->{dir} ! (directory does not exist)\n";
+ warning("cannot remove lab in directory $self->{dir} ! (directory does not exist)");
return 0;
}
@@ -213,7 +208,7 @@ sub delete_force {
return 1;
} else {
# non-empty directory that does not look like a lintian lab!
- print STDERR "warning: directory $self->{dir} does not look like a lab! (please remove it yourself)\n";
+ warning("directory $self->{dir} does not look like a lab! (please remove it yourself)");
return 0;
}
}
@@ -224,13 +219,13 @@ sub delete_force {
"$self->{dir}/source",
"$self->{dir}/udeb",
"$self->{dir}/info") != 0) {
- print STDERR "warning: cannot remove lab directory $self->{dir} (please remove it yourself)\n";
+ warning("cannot remove lab directory $self->{dir} (please remove it yourself)");
}
# dynamic lab?
if ($self->{mode} eq 'temporary') {
if (rmdir($self->{dir}) != 1) {
- print STDERR "warning: cannot remove lab directory $self->{dir} (please remove it yourself)\n";
+ warning("cannot remove lab directory $self->{dir} (please remove it yourself)");
}
}
diff --git a/lib/Util.pm b/lib/Util.pm
index be3b50f..f5a6866 100644
--- a/lib/Util.pm
+++ b/lib/Util.pm
@@ -37,6 +37,7 @@ our @EXPORT = qw(parse_dpkg_control
use FileHandle;
use Pipeline;
+use Lintian::Output qw(string);
use Digest::MD5;
# general function to read dpkg control files
@@ -260,17 +261,16 @@ sub perm2oct {
# ------------------------
sub fail {
- my $str = "internal error";
+ my $str;
if (@_) {
- $str .= ": ".join( "\n", @_)."\n";
+ $str = string('internal error', @_);
} elsif ($!) {
- $str .= ": $!\n";
+ $str = string('internal error', "$!");
} else {
- $str .= ".\n";
+ $str = string('internal error');
}
$! = 2; # set return code outside eval()
die $str;
-
}
1;
--
1.6.0.1
>From 3079b0d5668ed413a25ba81733500fbef7821f0c Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Fri, 19 Sep 2008 18:01:04 +0200
Subject: [PATCH] Do not use STDERR for debug output
I don't think this is something worth supporting in Lintian::Output.
---
frontend/lintian | 14 ++++++--------
lib/Lab.pm | 2 +-
2 files changed, 7 insertions(+), 9 deletions(-)
diff --git a/frontend/lintian b/frontend/lintian
index 9ebefdc..3bd17e8 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -1211,30 +1211,28 @@ if ($check_everything) {
read_bin_list("$LINTIAN_LAB/info/binary-packages", 0);
read_udeb_list("$LINTIAN_LAB/info/udeb-packages", 0);
- if ($debug >= 2) {
- print STDERR "pkg_mode = $pkg_mode\n";
- for my $arg (keys %source_info) {
- print STDERR $arg."\n";
- }
+ debug_msg(2, "pkg_mode = $pkg_mode");
+ for my $arg (keys %source_info) {
+ debug_msg(2, keys %source_info);
}
if (($pkg_mode eq 'a') or ($pkg_mode eq 's')) {
for my $arg (keys %source_info) {
- print STDERR "doing stuff with $LINTIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}\n" if $debug;
+ debug_msg(1, "doing stuff with $LINTIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}");
$schedule->add_file('s', "$LINTIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
%{$source_info{$arg}});
}
}
if (($pkg_mode eq 'a') or ($pkg_mode eq 'b')) {
for my $arg (keys %binary_info) {
- print STDERR "doing stuff with $LINTIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}\n" if $debug;
+ debug_msg(1, "doing stuff with $LINTIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}");
$schedule->add_file('b', "$LINTIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
%{$binary_info{$arg}});
}
}
if (($pkg_mode eq 'a') or ($pkg_mode eq 'u')) {
for my $arg (keys %udeb_info) {
- print STDERR "doing stuff with $LINTIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}\n" if $debug;
+ debug_msg(1, "doing stuff with $LINTIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}");
$schedule->add_file('u', "$LINTIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
%{$udeb_info{$arg}});
}
diff --git a/lib/Lab.pm b/lib/Lab.pm
index a111baf..c854885 100644
--- a/lib/Lab.pm
+++ b/lib/Lab.pm
@@ -138,7 +138,7 @@ sub populate_with_dist {
return 0 unless $dist;
return 0 unless $self->{dir};
- print STDERR "spawning list-binpkg, list-udebpkg and list-srcpkg since LINTIAN_DIST=$dist\n" if ($debug >= 2);
+ debug(2, "spawning list-binpkg, list-udebpkg and list-srcpkg since LINTIAN_DIST=$dist");
my $v = $Lintian::Output::GLOBAL->verbose ? '-v' : '';
--
1.6.0.1
>From 1eca4772fbc80272787d91840c03ed9edb246daa Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Sat, 20 Sep 2008 11:59:46 +0200
Subject: [PATCH] frontend/lintian: Improve extra information of file-size-mismatch-in-changes-file
Include size mismatch information in the tag output and do not output it
as a separate message.
---
frontend/lintian | 11 ++++++-----
1 files changed, 6 insertions(+), 5 deletions(-)
diff --git a/frontend/lintian b/frontend/lintian
index 3bd17e8..48c0803 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -821,7 +821,8 @@ while (my $arg = shift) {
my ($checksum,$size,$file) = split(/\s+/o, $_);
$files{$file}{$alg} = $checksum;
if ($files{$file}{size} != $size) {
- tag( "file-size-mismatch-in-changes-file", $file );
+ tag( "file-size-mismatch-in-changes-file", $file,
+ "$files{$file}{size} != $size" );
}
}
}
@@ -835,10 +836,10 @@ while (my $arg = shift) {
warn "E: $file does not exist, exiting\n";
exit(-1);
}
- if (-s _ ne $files{$file}{size}) {
- print "N: size is $files{$file}{size}, argname is $arg_name, filename is $filename\n";
-
- tag( "file-size-mismatch-in-changes-file", $file );
+ my $size = -s _;
+ if ($size ne $files{$file}{size}) {
+ tag( "file-size-mismatch-in-changes-file", $file,
+ "$files{$file}{size} != $size");
}
# check checksums
--
1.6.0.1
>From 9d5455aa9471c3327400d8cb5277f508a17bf4ff Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Sat, 20 Sep 2008 12:27:43 +0200
Subject: [PATCH] frontend/lintian: Unify warning output
Do not use both "error" and "warning", wasn't consistent anyway.
Do not use messages for warnings.
---
frontend/lintian | 60 +++++++++++++++++++++++++++---------------------------
1 files changed, 30 insertions(+), 30 deletions(-)
diff --git a/frontend/lintian b/frontend/lintian
index 48c0803..56e0c54 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -833,8 +833,8 @@ while (my $arg = shift) {
# check size
if (not -f $filename) {
- warn "E: $file does not exist, exiting\n";
- exit(-1);
+ warning("$file does not exist, exiting");
+ exit 2;
}
my $size = -s _;
if ($size ne $files{$file}{size}) {
@@ -936,20 +936,20 @@ while (my $arg = shift) {
}
} elsif ($pkg_mode eq 's') {
unless (-d $s) {
- warn "error: cannot find source package $arg in $search (skipping)\n";
+ warning("cannot find source package $arg in $search (skipping)");
$exit_code = 2;
next;
}
} elsif ($pkg_mode eq 'u') {
unless (-d $u) {
- warn "error: cannot find udeb package $arg in $search (skipping)\n";
+ warning("cannot find udeb package $arg in $search (skipping)");
$exit_code = 2;
next;
}
} else {
# $pkg_mode eq 'a'
unless (-d $b or -d $s or -d $u) {
- warn "error: cannot find binary, udeb or source package $arg in $search (skipping)\n";
+ warning("cannot find binary, udeb or source package $arg in $search (skipping)");
$exit_code = 2;
next;
}
@@ -1328,7 +1328,7 @@ foreach my $pkg_info ($schedule->get_all) {
# unpack level defined?
unless (exists $data->{'unpack-level'}) {
- print "N: warning: cannot determine unpack-level of package\n" if $verbose;
+ warning("cannot determine unpack-level of package");
$remove_basedir = 1;
goto REMOVE_BASEDIR;
} else {
@@ -1339,7 +1339,7 @@ foreach my $pkg_info ($schedule->get_all) {
my $timestamp;
my @stat;
unless (@stat = stat $file) {
- print "N: Cannot stat file $file: $!\n";
+ warning("cannot stat file $file: $!");
} else {
$timestamp = $stat[9];
}
@@ -1353,7 +1353,7 @@ foreach my $pkg_info ($schedule->get_all) {
if ($remove_basedir) {
v_msg("Removing $pkg");
unless (remove_pkg($base)) {
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
@@ -1365,8 +1365,8 @@ foreach my $pkg_info ($schedule->get_all) {
$act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,
$unpack_level);
if ($act_unpack_level == -1) {
- print STDERR "internal error: could not unpack package to desired level: $!\n";
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("could not unpack package to desired level: $!",
+ "skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
@@ -1384,16 +1384,16 @@ foreach my $pkg_info ($schedule->get_all) {
# unpack to desired unpack level (if necessary)
$act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
if ($act_unpack_level == -1) {
- print STDERR "internal error: could not unpack package to desired level: $!\n";
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("could not unpack package to desired level: $!",
+ "skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
# chdir to base directory
unless (chdir($base)) {
- print STDERR "internal error: could not chdir into directory $base: $!\n";
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("could not chdir into directory $base: $!",
+ "skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
@@ -1402,8 +1402,8 @@ foreach my $pkg_info ($schedule->get_all) {
remove_status_file($base);
debug_msg(1, "Collecting info: $coll ...");
if (spawn("$LINTIAN_ROOT/collection/$ci->{'script'}", $pkg, $long_type) != 0) {
- print STDERR "internal error: collect info $coll about package $pkg: $?\n";
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("collect info $coll about package $pkg: $?",
+ "skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
@@ -1443,16 +1443,16 @@ foreach my $pkg_info ($schedule->get_all) {
# unpack to desired unpack level (if necessary)
$act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
if ($act_unpack_level == -1) {
- print STDERR "internal error: could not unpack package to desired level: $!\n";
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("could not unpack package to desired level: $!",
+ "skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
# chdir to base directory
unless (chdir($base)) {
- print STDERR "internal error: could not chdir into directory $base: $!\n";
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("could not chdir into directory $base: $!",
+ "skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
@@ -1462,7 +1462,7 @@ foreach my $pkg_info ($schedule->get_all) {
$exit_code = $returnvalue unless $exit_code;
if ($returnvalue == 2) {
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("skipping $action of $long_type package $pkg");
next PACKAGE;
}
@@ -1503,8 +1503,8 @@ foreach my $pkg_info ($schedule->get_all) {
# chdir to lintian root directory (to unlock $base so it can be removed below)
unless (chdir($LINTIAN_ROOT)) {
- print STDERR "internal error: could not chdir into directory $LINTIAN_ROOT: $!\n";
- print "N: Skipping $action of $long_type package $pkg\n";
+ warning("could not chdir into directory $LINTIAN_ROOT: $!",
+ "skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
@@ -1513,8 +1513,8 @@ foreach my $pkg_info ($schedule->get_all) {
if ($act_unpack_level > $unpack_level) {
$act_unpack_level = clean_pkg($type,$base,$file,$act_unpack_level,$unpack_level);
if ($act_unpack_level == -1) {
- print STDERR "error: could not clean up laboratory for package $pkg: $!\n";
- print "N: Skipping clean up\n";
+ warning("could not clean up laboratory for package $pkg: $!",
+ "skipping clean up");
$exit_code = 2;
next PACKAGE;
}
@@ -1524,15 +1524,15 @@ foreach my $pkg_info ($schedule->get_all) {
if (($act_unpack_level > 0) and (not -f "$base/.lintian-status")) {
my @stat;
unless (@stat = stat $file) {
- print STDERR "internal error: cannot stat file $file: $!\n";
- print "N: Skipping creation of status file\n";
+ warning("cannot stat file $file: $!",
+ "skipping creation of status file");
$exit_code = 2;
next PACKAGE;
}
my $timestamp = $stat[9];
unless (open(STATUS, '>', "$base/.lintian-status")) {
- print STDERR "internal error: could not create status file $base/.lintian-status for package $pkg: $!\n";
+ warning("could not create status file $base/.lintian-status for package $pkg: $!");
$exit_code = 2;
next PACKAGE;
}
@@ -1662,7 +1662,7 @@ sub remove_pkg {
debug_msg(1, "Removing package in lab ...");
if (spawn('rm', '-rf', '--', $base) != 0) {
- print STDERR "error: cannot remove directory $base: $!\n";
+ warning("cannot remove directory $base: $!");
return 0;
}
@@ -1678,7 +1678,7 @@ sub remove_status_file {
}
if (not unlink("$base/.lintian-status")) {
- print STDERR "internal error: cannot remove status file $base/.lintian-status: $!\n";
+ warning("cannot remove status file $base/.lintian-status: $!");
return 0;
}
--
1.6.0.1
>From ad54e830fd1b54ca229aed6f51f26e4eecf90915 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Sat, 20 Sep 2008 12:29:54 +0200
Subject: [PATCH] Move tag output to Lintian::Output
Convert output format modules to subclasses of Lintian::Output.
Note: This commit breaks support for --color=html (which was undocumented
anyway and should be reimplemented as an own class) and changes the
behaviour of "--color=auto -i" (which could be fixed by not using
lintian-info for implementing -i anymore).
---
frontend/lintian | 11 ++--
lib/Lintian/Output.pm | 11 +++-
lib/Lintian/Output/ColonSeparated.pm | 93 ++++++++++++++++++++++++
lib/Lintian/Output/LetterQualifier.pm | 125 +++++++++++++++++++++++++++++++++
lib/Tags.pm | 48 +------------
lib/Tags/ColonSeparated.pm | 56 ---------------
lib/Tags/LetterQualifier.pm | 113 -----------------------------
7 files changed, 235 insertions(+), 222 deletions(-)
create mode 100644 lib/Lintian/Output/ColonSeparated.pm
create mode 100644 lib/Lintian/Output/LetterQualifier.pm
delete mode 100644 lib/Tags/ColonSeparated.pm
delete mode 100644 lib/Tags/LetterQualifier.pm
diff --git a/frontend/lintian b/frontend/lintian
index 56e0c54..52add08 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -51,7 +51,7 @@ our $display_experimentaltags = 0; #flag for -E|--display-experimental switch
my $unpack_level = undef; #flag for -l|--unpack-level switch
our $no_override = 0; #flag for -o|--no-override switch
our $show_overrides = 0; #flag for --show-overrides switch
-our $color = 'never'; #flag for --color switch
+my $color = 'never'; #flag for --color switch
my $check_checksums = 0; #flag for -m|--md5sums|--checksums switch
my $allow_root = 0; #flag for --allow-root switch
my $fail_on_warnings = 0; #flag for --fail-on-warnings switch
@@ -583,11 +583,11 @@ if (defined $experimental_output_opts) {
foreach (keys %opts) {
if ($_ eq 'format') {
if ($opts{$_} eq 'colons') {
- require Tags::ColonSeparated;
- $Tags::output_formatter = \&Tags::ColonSeparated::print_tag;
+ require Lintian::Output::ColonSeparated;
+ $Lintian::Output::GLOBAL = new Lintian::Output::ColonSeparated;
} elsif ($opts{$_} eq 'letterqualifier') {
- require Tags::LetterQualifier;
- $Tags::output_formatter = \&Tags::LetterQualifier::print_tag;
+ require Lintian::Output::LetterQualifier;
+ $Lintian::Output::GLOBAL = new Lintian::Output::LetterQualifier;
}
}
no strict 'refs';
@@ -622,7 +622,6 @@ $Tags::show_experimental = $display_experimentaltags;
$Tags::show_overrides = $show_overrides;
%Tags::display_level = %display_level;
%Tags::display_source = %display_source;
-$Tags::color = $color;
%Tags::only_issue_tags = map { $_ => 1 } (split(/,/, $check_tags))
if defined $check_tags;
use warnings;
diff --git a/lib/Lintian/Output.pm b/lib/Lintian/Output.pm
index 32827c1..3fc41aa 100644
--- a/lib/Lintian/Output.pm
+++ b/lib/Lintian/Output.pm
@@ -113,8 +113,7 @@ sub print_tag {
$type = " $pkg_info->{type}" if $pkg_info->{type} ne 'binary';
my $tag;
- if ($self->color eq 'always'
- || ($self->color eq 'auto' && -t $self->stdout)) {
+ if ($self->_do_color) {
$tag .= Term::ANSIColor::colored($tag_info->{tag}, $tag_color);
} else {
$tag .= $tag_info->{tag};
@@ -123,6 +122,14 @@ sub print_tag {
$self->_print('', "$code: $pkg_info->{pkg}$type", "$tag$extra");
}
+sub _do_color {
+ my ($self) = @_;
+
+ return ($self->color eq 'always'
+ || ($self->color eq 'auto'
+ && -t $self->stdout));
+}
+
sub delimiter {
my ($self) = _global_or_object(@_);
diff --git a/lib/Lintian/Output/ColonSeparated.pm b/lib/Lintian/Output/ColonSeparated.pm
new file mode 100644
index 0000000..ffbb5de
--- /dev/null
+++ b/lib/Lintian/Output/ColonSeparated.pm
@@ -0,0 +1,93 @@
+# Tags::ColonSeparated -- Perl tags functions for lintian
+# $Id: Tags.pm 489 2005-09-17 00:06:30Z djpig $
+
+# Copyright (C) 2005,2008 Frank Lichtenheld <frank@lichtenheld.de>
+#
+# 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., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Output::ColonSeparated;
+use strict;
+use warnings;
+
+use Lintian::Output qw(:util);
+use base qw(Lintian::Output);
+
+sub print_tag {
+ my ( $self, $pkg_info, $tag_info, $information ) = _global_or_object(@_);
+
+ my $extra = "@$information";
+
+ $self->_print(
+ 'tag',
+ $tag_info->{type},
+ $tag_info->{severity},
+ $tag_info->{certainty},
+ (exists($tag_info->{experimental}) ? 'X' : '').
+ ($tag_info->{overridden}{override} ? 'O' : ''),
+ @{$pkg_info}{'pkg','version','arch','type'},
+ $tag_info->{tag},
+ $extra,
+ $tag_info->{overridden}{override},
+ );
+}
+
+sub _delimiter {
+ return;
+}
+
+sub _message {
+ my ($self, @args) = @_;
+
+ foreach (@args) {
+ $self->_print('message', $_);
+ }
+}
+
+sub _warning {
+ my ($self, @args) = @_;
+
+ foreach (@args) {
+ $self->_print('warning', $_);
+ }
+}
+
+sub _print {
+ my ($self, @args) = @_;
+
+ my $output = $self->string(@args);
+ print {$self->stdout} $output;
+}
+
+sub string {
+ my ($self, @args) = _global_or_object(@_);
+
+ return join(':', _quote_char( ':', @args))."\n";
+}
+
+sub _quote_char {
+ my ( $char, @items ) = @_;
+
+ foreach (@items) {
+ s/\\/\\\\/go;
+ s/\Q$char\E/\\$char/go;
+ }
+
+ return @items;
+}
+
+1;
+
diff --git a/lib/Lintian/Output/LetterQualifier.pm b/lib/Lintian/Output/LetterQualifier.pm
new file mode 100644
index 0000000..20aa9c8
--- /dev/null
+++ b/lib/Lintian/Output/LetterQualifier.pm
@@ -0,0 +1,125 @@
+# Copyright © 2008 Jordà Polo <jorda@ettin.org>
+#
+# 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., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Output::LetterQualifier;
+
+use strict;
+use warnings;
+
+use Term::ANSIColor qw(colored);
+use Tags ();
+
+use Lintian::Output qw(:util);
+use base qw(Lintian::Output);
+
+my %codes = (
+ 'wishlist' => {
+ 'wild-guess' => 'W?',
+ 'possible' => 'W ',
+ 'certain' => 'W!'
+ },
+ 'minor' => {
+ 'wild-guess' => 'M?',
+ 'possible' => 'M ',
+ 'certain' => 'M!'
+ },
+ 'normal' => {
+ 'wild-guess' => 'N?',
+ 'possible' => 'N ',
+ 'certain' => 'N!'
+ },
+ 'important' => {
+ 'wild-guess' => 'I?',
+ 'possible' => 'I ',
+ 'certain' => 'I!'
+ },
+ 'serious' => {
+ 'wild-guess' => 'S?',
+ 'possible' => 'S ',
+ 'certain' => 'S!'
+ },
+);
+
+my %lq_default_colors = (
+ 'wishlist' => {
+ 'wild-guess' => 'green',
+ 'possible' => 'green',
+ 'certain' => 'cyan'
+ },
+ 'minor' => {
+ 'wild-guess' => 'green',
+ 'possible' => 'cyan',
+ 'certain' => 'yellow'
+ },
+ 'normal' => {
+ 'wild-guess' => 'cyan',
+ 'possible' => 'yellow',
+ 'certain' => 'yellow'
+ },
+ 'important' => {
+ 'wild-guess' => 'yellow',
+ 'possible' => 'red',
+ 'certain' => 'red'
+ },
+ 'serious' => {
+ 'wild-guess' => 'yellow',
+ 'possible' => 'red',
+ 'certain' => 'magenta'
+ },
+);
+
+sub new {
+ my $self = Lintian::Output::new('Lintian::Output::LetterQualifier');
+
+ $self->colors({%lq_default_colors});
+
+ return $self;
+}
+
+
+sub print_tag {
+ my ( $self, $pkg_info, $tag_info, $information ) = @_;
+
+ my $code = Tags::get_tag_code($tag_info);
+ $code = 'X' if exists $tag_info->{experimental};
+ $code = 'O' if $tag_info->{overridden}{override};
+
+ my $sev = $tag_info->{severity};
+ my $cer = $tag_info->{certainty};
+ my $lq = $codes{$sev}{$cer};
+
+ my $pkg = $pkg_info->{pkg};
+ my $type = ($pkg_info->{type} ne 'binary') ? " $pkg_info->{type}" : '';
+
+ my $tag = $tag_info->{tag};
+
+ my $extra = @$information ? " @$information" : '';
+ $extra = '' if $extra eq ' ';
+
+ if ($self->_do_color) {
+ my $color = $self->colors->{$sev}{$cer};
+ $lq = colored($lq, $color);
+ $tag = colored($tag, $color);
+ }
+
+ $self->_print('', "$code\[$lq\]: $pkg$type", "$tag$extra");
+}
+
+1;
+
+# vim: sw=4 sts=4 ts=4 et sr
diff --git a/lib/Tags.pm b/lib/Tags.pm
index 43f7e92..ef2d5f4 100644
--- a/lib/Tags.pm
+++ b/lib/Tags.pm
@@ -28,20 +28,11 @@ use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(tag);
-# support for ANSI color output via colored()
-use Term::ANSIColor;
-
-# Quiet "Name "main::LINTIAN_ROOT" used only once"
-# The variables comes from 'lintian'
-() = ($main::verbose, $main::debug);
+use Lintian::Output;
# configuration variables and defaults
-our $verbose = $::verbose;
-our $debug = $::debug;
our $show_experimental = 0;
our $show_overrides = 0;
-our $output_formatter = \&print_tag;
-our $color = 'never';
our %display_level;
our %display_source;
our %only_issue_tags;
@@ -87,8 +78,6 @@ my %codes = (
'serious' => { 'wild-guess' => 'E', 'possible' => 'E', 'certain' => 'E' },
);
-my %colors = ( 'E' => 'red' , 'W' => 'yellow' , 'I' => 'cyan' );
-
my %type_to_sev = (
'error' => 'important',
'warning' => 'normal',
@@ -259,38 +248,6 @@ sub get_stats {
return \%stats;
}
-# Color tags with HTML. Takes the tag and the color name.
-sub colored_html {
- my ($tag, $color) = @_;
- return qq(<span style="color: $color">$tag</span>);
-}
-
-sub print_tag {
- my ( $pkg_info, $tag_info, $information ) = @_;
-
- my $extra = '';
- $extra = " @$information" if @$information;
- $extra = '' if $extra eq ' ';
- my $code = get_tag_code($tag_info);
- my $tag_color = $colors{$code};
- $code = 'X' if exists $tag_info->{experimental};
- $code = 'O' if $tag_info->{overridden}{override};
- my $type = '';
- $type = " $pkg_info->{type}" if $pkg_info->{type} ne 'binary';
-
- my $output = "$code: $pkg_info->{pkg}$type: ";
- if ($color eq 'always' || ($color eq 'auto' && -t STDOUT)) {
- $output .= colored($tag_info->{tag}, $tag_color);
- } elsif ($color eq 'html') {
- $output .= colored_html($tag_info->{tag}, $tag_color);
- } else {
- $output .= $tag_info->{tag};
- }
- $output .= "$extra\n";
-
- print $output;
-}
-
# Extract manual sources from a given tag. Returns a hash that has manual
# names as keys and sections/ids has values.
sub get_tag_source {
@@ -361,7 +318,8 @@ sub tag {
return 1 if skip_print( $tag_info );
- &$output_formatter( $info{$current}, $tag_info, \@information );
+ $Lintian::Output::GLOBAL->print_tag( $info{$current}, $tag_info,
+ \@information );
return 1;
}
diff --git a/lib/Tags/ColonSeparated.pm b/lib/Tags/ColonSeparated.pm
deleted file mode 100644
index 37ec076..0000000
--- a/lib/Tags/ColonSeparated.pm
+++ /dev/null
@@ -1,56 +0,0 @@
-# Tags::ColonSeparated -- Perl tags functions for lintian
-# $Id: Tags.pm 489 2005-09-17 00:06:30Z djpig $
-
-# Copyright (C) 2005 Frank Lichtenheld <frank@lichtenheld.de>
-#
-# 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., 51 Franklin St, Fifth Floor, Boston,
-# MA 02110-1301, USA.
-
-package Tags::ColonSeparated;
-use strict;
-use warnings;
-
-sub quote_char {
- my ( $char, @items ) = @_;
-
- foreach (@items) {
- s/\\/\\\\/go;
- s/\Q$char\E/\\$char/go;
- }
-
- return @items;
-}
-
-sub print_tag {
- my ( $pkg_info, $tag_info, $information ) = @_;
-
- my $extra = "@$information";
-
- print join(':', quote_char( ':',
- $tag_info->{type},
- $tag_info->{severity},
- $tag_info->{certainty},
- (exists($tag_info->{experimental}) ? 'X' : '').
- ($tag_info->{overridden}{override} ? 'O' : ''),
- @{$pkg_info}{'pkg','version','arch','type'},
- $tag_info->{tag},
- $extra,
- $tag_info->{overridden}{override},
- ))."\n";
-}
-
-1;
-
diff --git a/lib/Tags/LetterQualifier.pm b/lib/Tags/LetterQualifier.pm
deleted file mode 100644
index 874ffcb..0000000
--- a/lib/Tags/LetterQualifier.pm
+++ /dev/null
@@ -1,113 +0,0 @@
-# Copyright © 2008 Jordà Polo <jorda@ettin.org>
-#
-# 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., 51 Franklin St, Fifth Floor, Boston,
-# MA 02110-1301, USA.
-
-package Tags::LetterQualifier;
-
-use strict;
-use warnings;
-
-use Term::ANSIColor;
-use Tags;
-
-my %codes = (
- 'wishlist' => {
- 'wild-guess' => 'W?',
- 'possible' => 'W ',
- 'certain' => 'W!'
- },
- 'minor' => {
- 'wild-guess' => 'M?',
- 'possible' => 'M ',
- 'certain' => 'M!'
- },
- 'normal' => {
- 'wild-guess' => 'N?',
- 'possible' => 'N ',
- 'certain' => 'N!'
- },
- 'important' => {
- 'wild-guess' => 'I?',
- 'possible' => 'I ',
- 'certain' => 'I!'
- },
- 'serious' => {
- 'wild-guess' => 'S?',
- 'possible' => 'S ',
- 'certain' => 'S!'
- },
-);
-
-my %colors = (
- 'wishlist' => {
- 'wild-guess' => 'green',
- 'possible' => 'green',
- 'certain' => 'cyan'
- },
- 'minor' => {
- 'wild-guess' => 'green',
- 'possible' => 'cyan',
- 'certain' => 'yellow'
- },
- 'normal' => {
- 'wild-guess' => 'cyan',
- 'possible' => 'yellow',
- 'certain' => 'yellow'
- },
- 'important' => {
- 'wild-guess' => 'yellow',
- 'possible' => 'red',
- 'certain' => 'red'
- },
- 'serious' => {
- 'wild-guess' => 'yellow',
- 'possible' => 'red',
- 'certain' => 'magenta'
- },
-);
-
-sub print_tag {
- my ( $pkg_info, $tag_info, $information ) = @_;
-
- my $code = Tags::get_tag_code($tag_info);
- $code = 'X' if exists $tag_info->{experimental};
- $code = 'O' if $tag_info->{overridden}{override};
-
- my $sev = $tag_info->{severity};
- my $cer = $tag_info->{certainty};
- my $lq = $codes{$sev}{$cer};
-
- my $pkg = $pkg_info->{pkg};
- my $type = ($pkg_info->{type} ne 'binary') ? " $pkg_info->{type}" : '';
-
- my $tag = $tag_info->{tag};
-
- my $extra = @$information ? " @$information" : '';
- $extra = '' if $extra eq ' ';
-
- if ($Tags::color eq 'always' || ($Tags::color eq 'auto' && -t STDOUT)) {
- my $color = $colors{$sev}{$cer};
- $lq = colored($lq, $color);
- $tag = colored($tag, $color);
- }
-
- print "$code\[$lq\]: $pkg$type: $tag$extra\n";
-}
-
-1;
-
-# vim: sw=4 sts=4 ts=4 et sr
--
1.6.0.1
Reply to: