Re: [RFC/PATCH] New Lintian::Output module
On Sat, Sep 20, 2008 at 01:57:45PM +0200, Frank Lichtenheld wrote:
> A patch series to bundle all the output logic of lintian into
> modules and to make it easier to define new output formats.
Attached you can find my current version of this branch.
(Since it has grown somewhat large, as a mbox instead of
separate files)
The module now also gets POD documentation and I've added
print_start_pkg and print_end_pkg hooks as well as a very
rough XML format for demonstrating the use of the hooks.
Gruesse,
--
Frank Lichtenheld <djpig@debian.org>
www: http://www.djpig.de/
>From 908fe99dd7f2c9ecc66a396348a3839ced264b58 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Fri, 19 Sep 2008 13:31:44 +0200
Subject: [PATCH 1/8] Lintian::Output: New module for bundeling lintian output functionality
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.6.0.1"
This is a multi-part message in MIME format.
--------------1.6.0.1
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
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
--------------1.6.0.1
Content-Type: text/x-patch; name="908fe99dd7f2c9ecc66a396348a3839ced264b58.diff"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline; filename="908fe99dd7f2c9ecc66a396348a3839ced264b58.diff"
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 ae8bafcab9dc2c6ede2eea78e122ed9cdc7d1379 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Fri, 19 Sep 2008 14:16:32 +0200
Subject: [PATCH 2/8] Begin conversion to Lintian::Output
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.6.0.1"
This is a multi-part message in MIME format.
--------------1.6.0.1
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
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(-)
--------------1.6.0.1
Content-Type: text/x-patch; name="ae8bafcab9dc2c6ede2eea78e122ed9cdc7d1379.diff"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline; filename="ae8bafcab9dc2c6ede2eea78e122ed9cdc7d1379.diff"
diff --git a/frontend/lintian b/frontend/lintian
index 789b87f..2ce3994 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
@@ -483,10 +481,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) {
@@ -620,22 +614,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)
@@ -654,10 +636,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) {
@@ -677,6 +657,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;
@@ -707,7 +710,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()
@@ -719,7 +722,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()
@@ -750,7 +753,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
@@ -758,10 +761,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;
}
}
# }}}
@@ -781,28 +784,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;
}
@@ -1027,7 +1030,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;
}
# }}}
@@ -1053,7 +1056,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)
@@ -1098,14 +1101,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);
@@ -1120,7 +1119,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;
@@ -1167,14 +1166,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;
@@ -1310,7 +1305,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);
@@ -1319,20 +1314,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;
@@ -1345,10 +1340,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
@@ -1356,7 +1348,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;
@@ -1370,7 +1362,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;
}
@@ -1379,21 +1371,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;
}
@@ -1416,14 +1408,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;
@@ -1472,7 +1464,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";
@@ -1622,7 +1614,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;
@@ -1641,7 +1633,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). ")");
}
}
@@ -1654,7 +1646,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;
@@ -1669,7 +1661,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;
@@ -1683,12 +1675,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;
}
@@ -1716,7 +1708,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;
@@ -1735,7 +1727,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 a64b5bb48ca8f19e9fdb8176b30fa0681470f238 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Fri, 19 Sep 2008 18:01:04 +0200
Subject: [PATCH 3/8] Do not use STDERR for debug output
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.6.0.1"
This is a multi-part message in MIME format.
--------------1.6.0.1
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
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(-)
--------------1.6.0.1
Content-Type: text/x-patch; name="a64b5bb48ca8f19e9fdb8176b30fa0681470f238.diff"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline; filename="a64b5bb48ca8f19e9fdb8176b30fa0681470f238.diff"
diff --git a/frontend/lintian b/frontend/lintian
index 2ce3994..601dbc4 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -1274,30 +1274,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 c4f9b03ad3692ee520883cbde9228539da7d5bf3 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Sat, 20 Sep 2008 12:27:43 +0200
Subject: [PATCH 4/8] frontend/lintian: Unify warning output
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.6.0.1"
This is a multi-part message in MIME format.
--------------1.6.0.1
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
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(-)
--------------1.6.0.1
Content-Type: text/x-patch; name="c4f9b03ad3692ee520883cbde9228539da7d5bf3.diff"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline; filename="c4f9b03ad3692ee520883cbde9228539da7d5bf3.diff"
diff --git a/frontend/lintian b/frontend/lintian
index 601dbc4..09bbfd2 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -895,8 +895,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}) {
@@ -998,20 +998,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;
}
@@ -1390,7 +1390,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 {
@@ -1401,7 +1401,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];
}
@@ -1415,7 +1415,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;
}
@@ -1427,8 +1427,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;
}
@@ -1446,16 +1446,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;
}
@@ -1464,8 +1464,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;
}
@@ -1506,16 +1506,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;
}
@@ -1525,7 +1525,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;
}
@@ -1568,8 +1568,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;
}
@@ -1578,8 +1578,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;
}
@@ -1589,15 +1589,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;
}
@@ -1727,7 +1727,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;
}
@@ -1743,7 +1743,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 2bac3c512d1418fffc4462603e6fe45a36c10117 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Sat, 20 Sep 2008 12:29:54 +0200
Subject: [PATCH 5/8] Move tag output to Lintian::Output
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.6.0.1"
This is a multi-part message in MIME format.
--------------1.6.0.1
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
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
--------------1.6.0.1
Content-Type: text/x-patch; name="2bac3c512d1418fffc4462603e6fe45a36c10117.diff"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline; filename="2bac3c512d1418fffc4462603e6fe45a36c10117.diff"
diff --git a/frontend/lintian b/frontend/lintian
index 09bbfd2..41c4aaf 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
@@ -645,11 +645,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';
@@ -684,7 +684,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 db9a402..e3b5379 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',
@@ -276,38 +265,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 {
@@ -378,7 +335,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--
>From a2c2f39ccf56b12c74d4749bf83ef9ba129c4c91 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Tue, 23 Sep 2008 16:12:39 +0200
Subject: [PATCH 6/8] Lintian::Output: Add POD documentation
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.6.0.1"
This is a multi-part message in MIME format.
--------------1.6.0.1
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
Reorder the code to fit better with the structure of the documentation.
---
lib/Lintian/Output.pm | 298 +++++++++++++++++++++++++++++++++++++++++++------
1 files changed, 265 insertions(+), 33 deletions(-)
--------------1.6.0.1
Content-Type: text/x-patch; name="a2c2f39ccf56b12c74d4749bf83ef9ba129c4c91.diff"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline; filename="a2c2f39ccf56b12c74d4749bf83ef9ba129c4c91.diff"
diff --git a/lib/Lintian/Output.pm b/lib/Lintian/Output.pm
index 3fc41aa..8547ff6 100644
--- a/lib/Lintian/Output.pm
+++ b/lib/Lintian/Output.pm
@@ -1,4 +1,4 @@
-# Copyright (C) 2008 Frank Lichtenheld <frank@lichtenheld.de>
+# Copyright © 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
@@ -23,10 +23,85 @@ use warnings;
use v5.8.0; # for PerlIO
+=head1 NAME
+
+Lintian::Output - Lintian messaging handling
+
+=head1 SYNOPSIS
+
+ # non-OO
+ use Lintian::Output qw(:messages)
+
+ $Lintian::Output::GLOBAL->verbose(1);
+
+ msg("Something interesting");
+ v_msg("Something less interesting");
+ debug_msg(3, "Something very specfific");
+
+ # OO
+ use Lintian::Output;
+
+ my $out = new Lintian::Output;
+
+ $out->quiet(1);
+ $out->msg("Something interesting");
+ $out->v_msg("Something less interesting");
+ $out->debug_msg(3, "Something very specfific");
+
+=head1 DESCRIPTION
+
+Lintian::Output is used for all interaction between lintian and the user.
+It is designed to be easily extendable via subclassing.
+
+To simplify usage in the most common cases, many Lintian::Output methods
+can be used as class methods and will therefor automatically use the object
+$Lintian::Output::GLOBAL unless their first argument C<isa('Lintian::Output')>.
+
+=cut
+
# support for ANSI color output via colored()
use Term::ANSIColor ();
use Tags ();
+=head1 ACCESSORS
+
+The following fields define the behaviours of Lintian::Output.
+
+=over 4
+
+=item quiet
+
+If true, will suppress all messages except for warnings.
+
+=item verbose
+
+If true, will enable messages issued with v_msg.
+
+=item debug
+
+If set to a positive integer, will enable all debug messages issued with
+a level lower or equal to its value.
+
+=item color
+
+Can take the values "never", "always", or "auto".
+
+Whether to colorize tags based on their severity. The default is "never",
+which never uses color. "always" will always use color, "auto" will use
+color only if the output is going to a terminal,
+
+=item stdout
+
+I/O handle to use for output of messages and tags. Defaults to C<\*STDOUT>.
+
+=item stderr
+
+I/O handle to use for warnings. Defaults to C<\*STDERR>.
+
+=back
+
+=cut
+
use base qw(Class::Accessor Exporter);
Lintian::Output->mk_accessors(qw(verbose debug quiet color colors stdout stderr));
@@ -55,19 +130,38 @@ sub new {
return $self;
}
-sub debug_msg {
- my ($self, $level, @args) = _global_or_object(@_);
+=head1 CLASS/INSTANCE METHODS
- return unless $self->debug && ($self->debug >= $level);
+These methods can be used both with and without an object. If no object
+is given, they will fall back to the $Lintian::Output::GLOBAL object.
- $self->_message(@args);
-}
+=over 4
-sub warning {
+=item C<msg(@args)>
+
+Will output the strings given in @args, one per line, each line prefixed
+with 'N: '. Will do nothing if quiet is true.
+
+=item C<v_msg(@args)>
+
+Will output the strings given in @args, one per line, each line prefixed
+with 'N: '. Will do nothing unless verbose is true.
+
+=item C<debug_msg($level, @args)>
+
+$level should be a positive integer.
+
+Will output the strings given in @args, one per line, each line prefixed
+with 'N: '. Will do nothing unless debug is set to a positive integer
+>= $level.
+
+=cut
+
+sub msg {
my ($self, @args) = _global_or_object(@_);
return if $self->quiet;
- $self->_warning(@args);
+ $self->_message(@args);
}
sub v_msg {
@@ -77,28 +171,52 @@ sub v_msg {
$self->_message(@args);
}
-sub msg {
+sub debug_msg {
+ my ($self, $level, @args) = _global_or_object(@_);
+
+ return unless $self->debug && ($self->debug >= $level);
+
+ $self->_message(@args);
+}
+
+=item C<warning(@args)>
+
+Will output the strings given in @args on stderr, one per line, each line
+prefixed with 'warning: '.
+
+=cut
+
+sub warning {
my ($self, @args) = _global_or_object(@_);
return if $self->quiet;
- $self->_message(@args);
+ $self->_warning(@args);
}
-sub string {
- my ($self, $lead, @args) = _global_or_object(@_);
+=item C<delimiter()>
- my $output = '';
- if (@args) {
- foreach (@args) {
- $output .= $lead.': '.$_."\n";
- }
- } elsif ($lead) {
- $output .= $lead.".\n";
- }
+Gives back a string that is usable for separating messages in the output.
+Note: This does not print anything, it just gives back the string, use
+with one of the methods above, e.g.
- return $output;
+ v_msg('foo', delimiter(), 'bar');
+
+=cut
+
+sub delimiter {
+ my ($self) = _global_or_object(@_);
+
+ return $self->_delimiter;
}
+=item C<print_tag($pkg_info, $tag_info, $extra)>
+
+Print a tag. The first two arguments are hash reference with the information
+about the package and the tag, $extra is the extra information for the tag
+(if any) as an array reference. Tags::tag() is a wrapper around this.
+
+=cut
+
sub print_tag {
my ( $self, $pkg_info, $tag_info, $information ) = _global_or_object(@_);
@@ -122,36 +240,82 @@ sub print_tag {
$self->_print('', "$code: $pkg_info->{pkg}$type", "$tag$extra");
}
-sub _do_color {
- my ($self) = @_;
+=item C<string($lead, @args)>
- return ($self->color eq 'always'
- || ($self->color eq 'auto'
- && -t $self->stdout));
-}
+TODO: Is the part of the public interface?
-sub delimiter {
- my ($self) = _global_or_object(@_);
+=cut
- return $self->_delimiter;
-}
+sub string {
+ my ($self, $lead, @args) = _global_or_object(@_);
-sub _delimiter {
- return '----';
+ my $output = '';
+ if (@args) {
+ foreach (@args) {
+ $output .= $lead.': '.$_."\n";
+ }
+ } elsif ($lead) {
+ $output .= $lead.".\n";
+ }
+
+ return $output;
}
+=back
+
+=head1 INSTANCE METHODS (for subclassing)
+
+The following methods are only intended for subclassing and are
+only available as instance methods. The methods mentioned above
+usually only check whether they should do anything at all (according
+to the values of quiet, verbose, and debug) and then call one of
+the following methods to do the actual printing. Allmost all of them
+finally call _print() to do that. This convoluted scheme is necessary
+to be able to use the methods above as class methods and still make
+the behaviour overridable in subclasses.
+
+=over 4
+
+=item C<_message(@args)>
+
+Called by msg(), v_msg(), and debug_msg() to print the
+message.
+
+=cut
+
sub _message {
my ($self, @args) = @_;
$self->_print('', 'N', @args);
}
+=item C<_warning(@args)>
+
+Called by warning() to print the warning.
+
+=cut
+
sub _warning {
my ($self, @args) = @_;
$self->_print($self->stderr, 'warning', @args);
}
+=item C<_print($stream, $lead, @args)>
+
+Called by _message(), _warning(), and print_tag() to do
+the actual printing.
+
+If you override these three methods, you can change
+the calling convention for this method to pretty much
+whatever you want.
+
+The version in Lintian::Output prints the strings in
+@args, one per line, each line preceded by $lead to
+the I/O handle given in $stream.
+
+=cut
+
sub _print {
my ($self, $stream, $lead, @args) = @_;
$stream ||= $self->stdout;
@@ -160,6 +324,46 @@ sub _print {
print {$stream} $output;
}
+=item C<_delimiter()>
+
+Called by delimiter().
+
+=cut
+
+sub _delimiter {
+ return '----';
+}
+
+=item C<_do_color()>
+
+Called by print_tag() to determine whether to produce colored
+output.
+
+=cut
+
+sub _do_color {
+ my ($self) = @_;
+
+ return ($self->color eq 'always'
+ || ($self->color eq 'auto'
+ && -t $self->stdout));
+}
+
+=back
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item C<_global_or_object(@args)>
+
+If $args[0] is a object which satisfies C<isa('Lintian::Output')>
+returns @args, otherwise returns C<($Lintian::Output::GLOBAL, @_)>.
+
+=back
+
+=cut
+
sub _global_or_object {
if (ref($_[0]) and $_[0]->isa('Lintian::Output')) {
return @_;
@@ -169,3 +373,31 @@ sub _global_or_object {
}
1;
+__END__
+
+=head1 EXPORTS
+
+Lintian::Output exports nothing by default, but the following export
+tags are available:
+
+=over 4
+
+=item :messages
+
+Exports all the methods in L<CLASS/INSTANCE METHODS>
+
+=item :util
+
+Exports all the methods in L<CLASS METHODS>
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
--------------1.6.0.1--
>From 3a25e33daefd0cd93658caba67c007172fd7ef47 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Wed, 24 Sep 2008 23:07:35 +0200
Subject: [PATCH 7/8] Lintian::Output: Add print_start_pkg and print_end_pkg hooks
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.6.0.1"
This is a multi-part message in MIME format.
--------------1.6.0.1
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
It might be useful to have the actual package meta information
available in the output module to allow more flexible formats.
---
frontend/lintian | 2 +-
lib/Lintian/Output.pm | 70 +++++++++++++++++++++++++--------
lib/Lintian/Output/ColonSeparated.pm | 2 +-
lib/Lintian/Output/LetterQualifier.pm | 2 +-
lib/Tags.pm | 10 ++++-
5 files changed, 65 insertions(+), 21 deletions(-)
--------------1.6.0.1
Content-Type: text/x-patch; name="3a25e33daefd0cd93658caba67c007172fd7ef47.diff"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline; filename="3a25e33daefd0cd93658caba67c007172fd7ef47.diff"
diff --git a/frontend/lintian b/frontend/lintian
index 41c4aaf..df5d91f 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -1337,7 +1337,6 @@ foreach my $pkg_info ($schedule->get_all) {
my $long_type = ($type eq 'b' ? 'binary' :
($type eq 's' ? 'source' : 'udeb' ));
- v_msg(delimiter(), "Processing $long_type package $pkg (version $ver) ...");
Tags::set_pkg( $file, $pkg, $ver, $arch, $long_type );
# determine base directory
@@ -1611,6 +1610,7 @@ foreach my $pkg_info ($schedule->get_all) {
close(STATUS);
}
}
+Tags::reset_pkg();
if ($action eq 'check' and not $no_override and not $show_overrides) {
my $errors = $overrides{errors} || 0;
my $warnings = $overrides{warnings} || 0;
diff --git a/lib/Lintian/Output.pm b/lib/Lintian/Output.pm
index 8547ff6..08a1e87 100644
--- a/lib/Lintian/Output.pm
+++ b/lib/Lintian/Output.pm
@@ -209,16 +209,47 @@ sub delimiter {
return $self->_delimiter;
}
+=item C<string($lead, @args)>
+
+TODO: Is this part of the public interface?
+
+=cut
+
+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;
+}
+
+=back
+
+=head1 INSTANCE METHODS FOR CONTEXT-AWARE OUTPUT
+
+The following methods are designed to be called at specific points
+during program execution and require very specific arguments. They
+can only be called as instance methods.
+
+=over 4
+
=item C<print_tag($pkg_info, $tag_info, $extra)>
Print a tag. The first two arguments are hash reference with the information
about the package and the tag, $extra is the extra information for the tag
-(if any) as an array reference. Tags::tag() is a wrapper around this.
+(if any) as an array reference. Called from Tags::tag().
=cut
sub print_tag {
- my ( $self, $pkg_info, $tag_info, $information ) = _global_or_object(@_);
+ my ($self, $pkg_info, $tag_info, $information) = @_;
my $extra = '';
$extra = " @$information" if @$information;
@@ -240,33 +271,38 @@ sub print_tag {
$self->_print('', "$code: $pkg_info->{pkg}$type", "$tag$extra");
}
-=item C<string($lead, @args)>
+=item C<print_start_pkg($pkg_info)>
-TODO: Is the part of the public interface?
+Called before lintian starts to handle each package. The version in
+Lintian::Output uses v_msg() for output. Called from Tags::select_pkg().
=cut
-sub string {
- my ($self, $lead, @args) = _global_or_object(@_);
+sub print_start_pkg {
+ my ($self, $pkg_info) = @_;
- my $output = '';
- if (@args) {
- foreach (@args) {
- $output .= $lead.': '.$_."\n";
- }
- } elsif ($lead) {
- $output .= $lead.".\n";
- }
+ $self->v_msg($self->delimiter,
+ "Processing $pkg_info->{type} package $pkg_info->{pkg} (version $pkg_info->{version}) ...");
+}
- return $output;
+=item C<print_start_pkg($pkg_info)>
+
+Called after lintian is finished with a package. The version in
+Lintian::Output does nothing. Called from Tags::select_pkg() and
+Tags::reset_pkg().
+
+=cut
+
+sub print_end_pkg {
}
=back
-=head1 INSTANCE METHODS (for subclassing)
+=head1 INSTANCE METHODS FOR SUBCLASSING
The following methods are only intended for subclassing and are
-only available as instance methods. The methods mentioned above
+only available as instance methods. The methods mentioned in
+L<CLASS/INSTANCE METHODS>
usually only check whether they should do anything at all (according
to the values of quiet, verbose, and debug) and then call one of
the following methods to do the actual printing. Allmost all of them
diff --git a/lib/Lintian/Output/ColonSeparated.pm b/lib/Lintian/Output/ColonSeparated.pm
index ffbb5de..c738da7 100644
--- a/lib/Lintian/Output/ColonSeparated.pm
+++ b/lib/Lintian/Output/ColonSeparated.pm
@@ -27,7 +27,7 @@ use Lintian::Output qw(:util);
use base qw(Lintian::Output);
sub print_tag {
- my ( $self, $pkg_info, $tag_info, $information ) = _global_or_object(@_);
+ my ($self, $pkg_info, $tag_info, $information) = @_;
my $extra = "@$information";
diff --git a/lib/Lintian/Output/LetterQualifier.pm b/lib/Lintian/Output/LetterQualifier.pm
index 20aa9c8..eaffc42 100644
--- a/lib/Lintian/Output/LetterQualifier.pm
+++ b/lib/Lintian/Output/LetterQualifier.pm
@@ -93,7 +93,7 @@ sub new {
sub print_tag {
- my ( $self, $pkg_info, $tag_info, $information ) = @_;
+ my ($self, $pkg_info, $tag_info, $information) = @_;
my $code = Tags::get_tag_code($tag_info);
$code = 'X' if exists $tag_info->{experimental};
diff --git a/lib/Tags.pm b/lib/Tags.pm
index e3b5379..68723ba 100644
--- a/lib/Tags.pm
+++ b/lib/Tags.pm
@@ -111,8 +111,8 @@ sub set_pkg {
return 0;
}
- $current = $file;
$info{$file} = {
+ file => $file,
pkg => $pkg,
version => $version,
arch => $arch,
@@ -125,6 +125,7 @@ sub set_pkg {
overrides => {},
};
+ select_pkg($file);
return 1;
}
@@ -138,12 +139,19 @@ sub select_pkg {
return 0;
}
+ if ($current) {
+ $Lintian::Output::GLOBAL->print_end_pkg($info{$current});
+ }
$current = $file;
+ $Lintian::Output::GLOBAL->print_start_pkg($info{$current});
return 1;
}
# only delete the value of 'current' without deleting any stored information
sub reset_pkg {
+ if ($current) {
+ $Lintian::Output::GLOBAL->print_end_pkg($info{$current});
+ }
undef $current;
return 1;
}
--------------1.6.0.1--
>From c352ea929ff8df90775095b4e47c7243b1e1c8e7 Mon Sep 17 00:00:00 2001
From: Frank Lichtenheld <djpig@debian.org>
Date: Wed, 24 Sep 2008 23:31:14 +0200
Subject: [PATCH 8/8] Add an XML output as demonstration for print_{start,end}_pkg
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.6.0.1"
This is a multi-part message in MIME format.
--------------1.6.0.1
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
---
frontend/lintian | 3 ++
lib/Lintian/Output/XML.pm | 73 +++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 76 insertions(+), 0 deletions(-)
create mode 100644 lib/Lintian/Output/XML.pm
--------------1.6.0.1
Content-Type: text/x-patch; name="c352ea929ff8df90775095b4e47c7243b1e1c8e7.diff"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline; filename="c352ea929ff8df90775095b4e47c7243b1e1c8e7.diff"
diff --git a/frontend/lintian b/frontend/lintian
index df5d91f..24a3f41 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -650,6 +650,9 @@ if (defined $experimental_output_opts) {
} elsif ($opts{$_} eq 'letterqualifier') {
require Lintian::Output::LetterQualifier;
$Lintian::Output::GLOBAL = new Lintian::Output::LetterQualifier;
+ } elsif ($opts{$_} eq 'xml') {
+ require Lintian::Output::XML;
+ $Lintian::Output::GLOBAL = new Lintian::Output::XML;
}
}
no strict 'refs';
diff --git a/lib/Lintian/Output/XML.pm b/lib/Lintian/Output/XML.pm
new file mode 100644
index 0000000..7913f17
--- /dev/null
+++ b/lib/Lintian/Output/XML.pm
@@ -0,0 +1,73 @@
+# Copyright © 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::XML;
+use strict;
+use warnings;
+
+use HTML::Entities;
+
+use Lintian::Output qw(:util);
+use base qw(Lintian::Output);
+
+sub print_tag {
+ my ($self, $pkg_info, $tag_info, $information) = @_;
+
+ $self->_print_xml('',
+ qq{<tag severity="$tag_info->{severity}" certainty="$tag_info->{certainty}"},
+ 'flags="'.(exists($tag_info->{experimental}) ? 'experimental' : ''),
+ ($tag_info->{overridden}{override} ? 'overridden' : '').'"',
+ qq{name="$tag_info->{tag}">}.encode_entities("@$information","<>&\"'").qq{</tag},
+ );
+}
+
+sub print_start_pkg {
+ my ($self, $pkg_info) = @_;
+
+ $self->_print_xml('',
+ qq{<package type="$pkg_info->{type}" name="$pkg_info->{pkg}"},
+ qq{architecture="$pkg_info->{arch}" version="$pkg_info->{version}">}
+ );
+}
+
+sub print_end_pkg {
+ my ($self) = @_;
+ $self->_print_xml('', '</package>');
+}
+
+sub _delimiter {
+ return;
+}
+
+sub _print {
+ my ($self, $stream, $lead, @args) = @_;
+ $stream ||= $self->stderr;
+
+ my $output = $self->string($lead, @args);
+ print {$stream} $output;
+}
+
+sub _print_xml {
+ my ($self, $stream, @args) = @_;
+ $stream ||= $self->stdout;
+
+ print {$stream} join(' ',@args), "\n";
+}
+
+1;
+
--------------1.6.0.1--
Reply to: