From a4bdb88d40baeb8bbb9b279d35384ba7ba7c4ea6 Mon Sep 17 00:00:00 2001 From: Jeremiah Foster Date: Fri, 22 May 2009 19:19:39 +0300 Subject: [PATCH] A very minimal script, but you can feed it a .dsc file, and it should know what to do with it. --- lib/Maemian/Output.pm | 498 +++++++++++++++++++++++++++++++++++++++++++++++++ maemian | 17 +- 2 files changed, 513 insertions(+), 2 deletions(-) create mode 100644 lib/Maemian/Output.pm diff --git a/lib/Maemian/Output.pm b/lib/Maemian/Output.pm new file mode 100644 index 0000000..745abfc --- /dev/null +++ b/lib/Maemian/Output.pm @@ -0,0 +1,498 @@ +# Copyright © 2008 Frank Lichtenheld +# +# 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 Maemian::Output; + +use strict; +use warnings; + +use v5.8.0; # for PerlIO +use base qw(Class::Accessor Exporter); + +# Force export as soon as possible, since some of the modules we load also +# depend on us and the sequencing can cause things not to be exported +# otherwise. +our (@EXPORT, %EXPORT_TAGS, @EXPORT_OK); +BEGIN { + @EXPORT = (); + %EXPORT_TAGS = ( messages => [qw(msg v_msg warning debug_msg delimiter)], + util => [qw(_global_or_object)]); + @EXPORT_OK = (@{$EXPORT_TAGS{messages}}, + @{$EXPORT_TAGS{util}}, + 'string'); +} + +=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. + +=cut + +# support for ANSI color output via colored() +use Term::ANSIColor (); +use Maemian::Tag::Info (); +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", "auto" or "html". + +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. + +"html" will output HTML tags with a color style attribute (instead +of ANSI color escape sequences). + +=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>. + +=item showdescription + +Whether to show the description of a tag when printing it. + +=item issuedtags + +Hash containing the names of tags which have been issued. + +=back + +=cut + +Maemian::Output->mk_accessors(qw(verbose debug quiet color colors stdout + stderr showdescription issuedtags)); + +# for the non-OO interface +my %default_colors = ( 'E' => 'red' , 'W' => 'yellow' , 'I' => 'cyan', + 'P' => 'green' ); + +our $GLOBAL = new Lintian::Output; + +sub new { + my ($class, %options) = @_; + my $self = { %options }; + + bless($self, $class); + + $self->stdout(\*STDOUT); + $self->stderr(\*STDERR); + $self->colors({%default_colors}); + $self->issuedtags({}); + + return $self; +} + +=head1 CLASS/INSTANCE METHODS + +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. + +=over 4 + +=item C + +Will output the strings given in @args, one per line, each line prefixed +with 'N: '. Will do nothing if quiet is true. + +=item C + +Will output the strings given in @args, one per line, each line prefixed +with 'N: '. Will do nothing unless verbose is true. + +=item C + +$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->_message(@args); +} + +sub v_msg { + my ($self, @args) = _global_or_object(@_); + + return unless $self->verbose; + $self->_message(@args); +} + +sub debug_msg { + my ($self, $level, @args) = _global_or_object(@_); + + return unless $self->debug && ($self->debug >= $level); + + $self->_message(@args); +} + +=item C + +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->_warning(@args); +} + +=item C + +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. + + v_msg('foo', delimiter(), 'bar'); + +=cut + +sub delimiter { + my ($self) = _global_or_object(@_); + + return $self->_delimiter; +} + +=item C + +Indicate that the named tag has been issued. Returns a boolean value +indicating whether the tag had previously been issued by the object. + +=cut + +sub issued_tag { + my ($self, $tag_name) = _global_or_object(@_); + + return $self->issuedtags->{$tag_name}++ ? 1 : 0; +} + +=item C + +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 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. Called from Tags::tag(). + +=cut + +sub print_tag { + my ($self, $pkg_info, $tag_info, $information) = @_; + $information = ' ' . $information if $information ne ''; + 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->_do_color) { + if ($self->color eq 'html') { + my $escaped = $tag_info->{tag}; + $escaped =~ s/&/&/g; + $escaped =~ s//>/g; + $tag .= qq($escaped) + } else { + $tag .= Term::ANSIColor::colored($tag_info->{tag}, $tag_color); + } + } else { + $tag .= $tag_info->{tag}; + } + + $self->_print('', "$code: $pkg_info->{pkg}$type", "$tag$information"); + if (!$self->issued_tag($tag_info->{tag}) and $self->showdescription) { + my $info = Lintian::Tag::Info->new($tag_info->{tag}); + if ($info) { + my $description; + if ($self->_do_color && $self->color eq 'html') { + $description = $info->description('html', ' '); + } else { + $description = $info->description('text', ' '); + } + $self->_print('', 'N', ''); + $self->_print('', 'N', split("\n", $description)); + $self->_print('', 'N', ''); + } + } +} + +=item C + +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 print_start_pkg { + my ($self, $pkg_info) = @_; + + $self->v_msg($self->delimiter, + "Processing $pkg_info->{type} package $pkg_info->{pkg} (version $pkg_info->{version}) ..."); +} + +=item C + +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 + +The following methods are only intended for subclassing and are +only available as instance methods. The methods mentioned in +L +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; + + my $output = $self->string($lead, @args); + 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 'html' + || ($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 +returns @args, otherwise returns C<($Lintian::Output::GLOBAL, @_)>. + +=back + +=cut + +sub _global_or_object { + if (ref($_[0]) and $_[0]->isa('Lintian::Output')) { + return @_; + } else { + return ($Lintian::Output::GLOBAL, @_); + } +} + +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 + +=item :util + +Exports all the methods in L + +=back + +=head1 AUTHOR + +Originally written by Frank Lichtenheld for Lintian. + +=head1 SEE ALSO + +lintian(1) + +=cut + +# Local Variables: +# indent-tabs-mode: t +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 ts=8 noet shiftround diff --git a/maemian b/maemian index 94e4eaf..5d54506 100755 --- a/maemian +++ b/maemian @@ -35,6 +35,10 @@ use strict; use warnings; use Getopt::Long; use Carp; +# Cannot yet pull in all of Lintian +# unshift @INC, "/home/jeremiah/maemian/lib"; +# require Maemian::Output; +# my $lintout = new Maemian::Output; # --- Command line options my $inputfile; # --- A file passed to maemian @@ -54,11 +58,20 @@ sub file_tests { my @lines = <$file>; close $file; + my ($field, $maintainer) = map { split /: / } grep /Maintainer/, @lines; + chomp($maintainer); + if ($maintainer =~ /(ubuntu|debian)/i) { + print "W: Maintainer email addres ($maintainer) might be the same as upstream.\n"; + } + else { + print "N: $maintainer\n"; + } if (grep /BEGIN PGP SIGNED MESSAGE/, @lines) { - print "$filename is signed\n"; + print "N: $filename is signed\n"; } # print "\n$dirs\n$filename\n"; - } else { + } + else { croak "File not readable: $!\n"; } } -- 1.7.9.5