1 # Copyright © 2008 Frank Lichtenheld <frank@lichtenheld.de>
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 2 of the License, or
6 # (at your option) any later version.
8 # This program is distributed in the hope that it will be useful,
9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License for more details.
13 # You should have received a copy of the GNU General Public License
14 # along with this program. If not, you can find it on the World Wide
15 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
16 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
19 package Maemian::Output;
24 use v5.8.0; # for PerlIO
25 use base qw(Class::Accessor Exporter);
27 # Force export as soon as possible, since some of the modules we load also
28 # depend on us and the sequencing can cause things not to be exported
30 our (@EXPORT, %EXPORT_TAGS, @EXPORT_OK);
33 %EXPORT_TAGS = ( messages => [qw(msg v_msg warning debug_msg delimiter)],
34 util => [qw(_global_or_object)]);
35 @EXPORT_OK = (@{$EXPORT_TAGS{messages}},
36 @{$EXPORT_TAGS{util}},
42 Lintian::Output - Lintian messaging handling
47 use Lintian::Output qw(:messages)
49 $Lintian::Output::GLOBAL->verbose(1);
51 msg("Something interesting");
52 v_msg("Something less interesting");
53 debug_msg(3, "Something very specfific");
58 my $out = new Lintian::Output;
61 $out->msg("Something interesting");
62 $out->v_msg("Something less interesting");
63 $out->debug_msg(3, "Something very specfific");
67 Lintian::Output is used for all interaction between lintian and the user.
68 It is designed to be easily extendable via subclassing.
70 To simplify usage in the most common cases, many Lintian::Output methods
71 can be used as class methods and will therefor automatically use the object
72 $Lintian::Output::GLOBAL unless their first argument C<isa('Lintian::Output')>.
76 # support for ANSI color output via colored()
77 use Term::ANSIColor ();
78 use Maemian::Tag::Info ();
83 The following fields define the behaviours of Lintian::Output.
89 If true, will suppress all messages except for warnings.
93 If true, will enable messages issued with v_msg.
97 If set to a positive integer, will enable all debug messages issued with
98 a level lower or equal to its value.
102 Can take the values "never", "always", "auto" or "html".
104 Whether to colorize tags based on their severity. The default is "never",
105 which never uses color. "always" will always use color, "auto" will use
106 color only if the output is going to a terminal.
108 "html" will output HTML <span> tags with a color style attribute (instead
109 of ANSI color escape sequences).
113 I/O handle to use for output of messages and tags. Defaults to C<\*STDOUT>.
117 I/O handle to use for warnings. Defaults to C<\*STDERR>.
119 =item showdescription
121 Whether to show the description of a tag when printing it.
125 Hash containing the names of tags which have been issued.
131 Maemian::Output->mk_accessors(qw(verbose debug quiet color colors stdout
132 stderr showdescription issuedtags));
134 # for the non-OO interface
135 my %default_colors = ( 'E' => 'red' , 'W' => 'yellow' , 'I' => 'cyan',
138 our $GLOBAL = new Lintian::Output;
141 my ($class, %options) = @_;
142 my $self = { %options };
144 bless($self, $class);
146 $self->stdout(\*STDOUT);
147 $self->stderr(\*STDERR);
148 $self->colors({%default_colors});
149 $self->issuedtags({});
154 =head1 CLASS/INSTANCE METHODS
156 These methods can be used both with and without an object. If no object
157 is given, they will fall back to the $Lintian::Output::GLOBAL object.
163 Will output the strings given in @args, one per line, each line prefixed
164 with 'N: '. Will do nothing if quiet is true.
166 =item C<v_msg(@args)>
168 Will output the strings given in @args, one per line, each line prefixed
169 with 'N: '. Will do nothing unless verbose is true.
171 =item C<debug_msg($level, @args)>
173 $level should be a positive integer.
175 Will output the strings given in @args, one per line, each line prefixed
176 with 'N: '. Will do nothing unless debug is set to a positive integer
182 my ($self, @args) = _global_or_object(@_);
184 return if $self->quiet;
185 $self->_message(@args);
189 my ($self, @args) = _global_or_object(@_);
191 return unless $self->verbose;
192 $self->_message(@args);
196 my ($self, $level, @args) = _global_or_object(@_);
198 return unless $self->debug && ($self->debug >= $level);
200 $self->_message(@args);
203 =item C<warning(@args)>
205 Will output the strings given in @args on stderr, one per line, each line
206 prefixed with 'warning: '.
211 my ($self, @args) = _global_or_object(@_);
213 return if $self->quiet;
214 $self->_warning(@args);
219 Gives back a string that is usable for separating messages in the output.
220 Note: This does not print anything, it just gives back the string, use
221 with one of the methods above, e.g.
223 v_msg('foo', delimiter(), 'bar');
228 my ($self) = _global_or_object(@_);
230 return $self->_delimiter;
233 =item C<issued_tag($tag_name)>
235 Indicate that the named tag has been issued. Returns a boolean value
236 indicating whether the tag had previously been issued by the object.
241 my ($self, $tag_name) = _global_or_object(@_);
243 return $self->issuedtags->{$tag_name}++ ? 1 : 0;
246 =item C<string($lead, @args)>
248 TODO: Is this part of the public interface?
253 my ($self, $lead, @args) = _global_or_object(@_);
258 $output .= $lead.': '.$_."\n";
261 $output .= $lead.".\n";
269 =head1 INSTANCE METHODS FOR CONTEXT-AWARE OUTPUT
271 The following methods are designed to be called at specific points
272 during program execution and require very specific arguments. They
273 can only be called as instance methods.
277 =item C<print_tag($pkg_info, $tag_info, $extra)>
279 Print a tag. The first two arguments are hash reference with the information
280 about the package and the tag, $extra is the extra information for the tag
281 (if any) as an array reference. Called from Tags::tag().
286 my ($self, $pkg_info, $tag_info, $information) = @_;
287 $information = ' ' . $information if $information ne '';
288 my $code = Tags::get_tag_code($tag_info);
289 my $tag_color = $self->{colors}{$code};
290 $code = 'X' if exists $tag_info->{experimental};
291 $code = 'O' if $tag_info->{overridden}{override};
293 $type = " $pkg_info->{type}" if $pkg_info->{type} ne 'binary';
296 if ($self->_do_color) {
297 if ($self->color eq 'html') {
298 my $escaped = $tag_info->{tag};
299 $escaped =~ s/&/&/g;
300 $escaped =~ s/</</g;
301 $escaped =~ s/>/>/g;
302 $tag .= qq(<span style="color: $tag_color">$escaped</span>)
304 $tag .= Term::ANSIColor::colored($tag_info->{tag}, $tag_color);
307 $tag .= $tag_info->{tag};
310 $self->_print('', "$code: $pkg_info->{pkg}$type", "$tag$information");
311 if (!$self->issued_tag($tag_info->{tag}) and $self->showdescription) {
312 my $info = Lintian::Tag::Info->new($tag_info->{tag});
315 if ($self->_do_color && $self->color eq 'html') {
316 $description = $info->description('html', ' ');
318 $description = $info->description('text', ' ');
320 $self->_print('', 'N', '');
321 $self->_print('', 'N', split("\n", $description));
322 $self->_print('', 'N', '');
327 =item C<print_start_pkg($pkg_info)>
329 Called before lintian starts to handle each package. The version in
330 Lintian::Output uses v_msg() for output. Called from Tags::select_pkg().
334 sub print_start_pkg {
335 my ($self, $pkg_info) = @_;
337 $self->v_msg($self->delimiter,
338 "Processing $pkg_info->{type} package $pkg_info->{pkg} (version $pkg_info->{version}) ...");
341 =item C<print_start_pkg($pkg_info)>
343 Called after lintian is finished with a package. The version in
344 Lintian::Output does nothing. Called from Tags::select_pkg() and
354 =head1 INSTANCE METHODS FOR SUBCLASSING
356 The following methods are only intended for subclassing and are
357 only available as instance methods. The methods mentioned in
358 L<CLASS/INSTANCE METHODS>
359 usually only check whether they should do anything at all (according
360 to the values of quiet, verbose, and debug) and then call one of
361 the following methods to do the actual printing. Allmost all of them
362 finally call _print() to do that. This convoluted scheme is necessary
363 to be able to use the methods above as class methods and still make
364 the behaviour overridable in subclasses.
368 =item C<_message(@args)>
370 Called by msg(), v_msg(), and debug_msg() to print the
376 my ($self, @args) = @_;
378 $self->_print('', 'N', @args);
381 =item C<_warning(@args)>
383 Called by warning() to print the warning.
388 my ($self, @args) = @_;
390 $self->_print($self->stderr, 'warning', @args);
393 =item C<_print($stream, $lead, @args)>
395 Called by _message(), _warning(), and print_tag() to do
398 If you override these three methods, you can change
399 the calling convention for this method to pretty much
402 The version in Lintian::Output prints the strings in
403 @args, one per line, each line preceded by $lead to
404 the I/O handle given in $stream.
409 my ($self, $stream, $lead, @args) = @_;
410 $stream ||= $self->stdout;
412 my $output = $self->string($lead, @args);
413 print {$stream} $output;
416 =item C<_delimiter()>
418 Called by delimiter().
428 Called by print_tag() to determine whether to produce colored
436 return ($self->color eq 'always' || $self->color eq 'html'
437 || ($self->color eq 'auto'
438 && -t $self->stdout));
447 =item C<_global_or_object(@args)>
449 If $args[0] is a object which satisfies C<isa('Lintian::Output')>
450 returns @args, otherwise returns C<($Lintian::Output::GLOBAL, @_)>.
456 sub _global_or_object {
457 if (ref($_[0]) and $_[0]->isa('Lintian::Output')) {
460 return ($Lintian::Output::GLOBAL, @_);
469 Lintian::Output exports nothing by default, but the following export
476 Exports all the methods in L<CLASS/INSTANCE METHODS>
480 Exports all the methods in L<CLASS METHODS>
486 Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian.
495 # indent-tabs-mode: t
496 # cperl-indent-level: 4
498 # vim: syntax=perl sw=4 ts=8 noet shiftround