+++ /dev/null
-# Tags -- Perl tags functions for lintian
-# $Id$
-
-# Copyright (C) 1998-2004 Various authors
-# 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;
-use strict;
-use warnings;
-
-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);
-
-# configuration variables and defaults
-our $verbose = $::verbose;
-our $debug = $::debug;
-our $show_info = 0;
-our $show_experimental = 0;
-our $show_overrides = 0;
-our $output_formatter = \&print_tag;
-our $min_severity = 1;
-our $max_severity = 99;
-our $min_significance = 1;
-our $max_significance = 99;
-our $color = 'never';
-
-# The master hash with all tag info. Key is the tag name, value another hash
-# with the following keys:
-# - tag: short name
-# - type: error/warning/info/experimental
-# - info: Description in HTML
-# - ref: Any references
-# - experimental: experimental status (possibly undef)
-my %tags;
-
-# Statistics per file. Key is the filename, value another hash with the
-# following keys:
-# - overrides
-# - tags
-# - severity
-# - significance
-my %stats;
-
-# Info about a specific file. Key is the the filename, value another hash
-# with the following keys:
-# - pkg: package name
-# - version: package version
-# - arch: package architecture
-# - type: one of 'binary', 'udeb' or 'source'
-# - overrides: hash with all overrides for this file as keys
-my %info;
-
-# Currently selected file (not package!)
-my $current;
-
-# Compatibility stuff
-my %codes = ( 'error' => 'E' , 'warning' => 'W' , 'info' => 'I' );
-our %type_to_sev = ( error => 4, warning => 2, info => 0 );
-our @sev_to_type = qw( info warning warning error error );
-
-my @sig_to_qualifier = ( '??', '?', '', '!' );
-my @sev_to_code = qw( I W W E E );
-my @sev_to_color = ( 'cyan', 'yellow', 'yellow', 'red', 'red' );
-
-# Add a new tag, supplied as a hash reference
-sub add_tag {
- my $newtag = shift;
- if (exists $tags{$newtag->{tag}}) {
- warn "Duplicate tag: $newtag->{tag}\n";
- return 0;
- }
-
- # smooth transition
- $newtag->{type} = $sev_to_type[$newtag->{severity}]
- unless $newtag->{type};
- $newtag->{significance} = 2 unless exists $newtag->{significance};
- $newtag->{severity} = $type_to_sev{$newtag->{type}}
- unless exists $newtag->{severity};
- $tags{$newtag->{'tag'}} = $newtag;
- return 1;
-}
-
-# Add another file, will fail if there is already stored info about
-# the file
-sub set_pkg {
- my ( $file, $pkg, $version, $arch, $type ) = @_;
-
- if (exists $info{$file}) {
- warn "File $file was already processed earlier\n";
- return 0;
- }
-
- $current = $file;
- $info{$file} = {
- pkg => $pkg,
- version => $version,
- arch => $arch,
- type => $type,
- overrides => {},
- };
- $stats{$file} = {
- severity => {},
- significance => {},
- tags => {},
- overrides => {},
- };
-
- return 1;
-}
-
-# select another file as 'current' without deleting or adding any information
-# the file must have been added with add_pkg
-sub select_pkg {
- my ( $file ) = @_;
-
- unless (exists $info{$file}) {
- warn "Can't select package $file";
- return 0;
- }
-
- $current = $file;
- return 1;
-}
-
-# only delete the value of 'current' without deleting any stored information
-sub reset_pkg {
- undef $current;
- return 1;
-}
-
-# delete all the stored information (including tags)
-sub reset {
- undef %stats;
- undef %info;
- undef %tags;
- undef $current;
- return 1;
-}
-
-# Add an override. If you specifiy two arguments, the first will be taken
-# as file to add the override to, otherwise 'current' will be assumed
-sub add_override {
- my ($tag, $file) = ( "", "" );
- if (@_ > 1) {
- ($file, $tag) = @_;
- } else {
- ($file, $tag) = ($current, @_);
- }
-
- unless ($file) {
- warn "Don't know which package to add override $tag to";
- return 0;
- }
-
- $info{$file}{overrides}{$tag} = 0;
-
- return 1;
-}
-
-sub get_overrides {
- my ($file) = @_;
-
- unless ($file) {
- warn "Don't know which package to get overrides from";
- return undef;
- }
-
- return $info{$file}{overrides};
-}
-
-# Get the info hash for a tag back as a reference. The hash will be
-# copied first so that you can edit it safely
-sub get_tag_info {
- my ( $tag ) = @_;
- return { %{$tags{$tag}} } if exists $tags{$tag};
- return undef;
-}
-
-sub check_range {
- my ( $x, $min, $max ) = @_;
-
- return -1 if $x < $min;
- return 1 if $x > $max;
- return 0;
-}
-
-# check if a certain tag has a override for the 'current' package
-sub check_overrides {
- my ( $tag_info, $information ) = @_;
-
- my $extra = '';
- $extra = " @$information" if @$information;
- $extra = '' if $extra eq ' ';
- if( exists $info{$current}{overrides}{$tag_info->{tag}}) {
- $info{$current}{overrides}{$tag_info->{tag}}++;
- return $tag_info->{tag};
- } elsif( exists $info{$current}{overrides}{"$tag_info->{tag}$extra"} ) {
- $info{$current}{overrides}{"$tag_info->{tag}$extra"}++;
- return "$tag_info->{tag}$extra";
- }
-
- return '';
-}
-
-# sets all the overridden fields of a tag_info hash correctly
-sub check_need_to_show {
- my ( $tag_info, $information ) = @_;
- $tag_info->{overridden}{override} = check_overrides( $tag_info,
- $information );
- my $min_sev = $show_info ? 0 : $min_severity; # compat hack
- $tag_info->{overridden}{severity} = check_range( $tag_info->{severity},
- $min_sev,
- $max_severity );
- $tag_info->{overridden}{significance} = check_range( $tag_info->{significance},
- $min_significance,
- $max_significance );
-}
-
-# records the stats for a given tag_info hash
-sub record_stats {
- my ( $tag_info ) = @_;
-
- for my $k (qw( severity significance tag )) {
- $stats{$current}{$k}{$tag_info->{$k}}++
- unless $tag_info->{overridden}{override}
- || $tag_info->{overridden}{severity}
- || $tag_info->{overridden}{significance};
- }
- for my $k (qw( severity significance override )) {
- $stats{$current}{overrides}{$k}{$tag_info->{overridden}{$k}}++
- if $tag_info->{overridden}{$k};
- }
- if ($tag_info->{overridden}{override}) {
- $stats{$current}{overrides}{by_severity}{$tag_info->{severity}}++;
- }
-}
-
-# get the statistics for a file (one argument) or for all files (no argument)
-sub get_stats {
- my ( $file ) = @_;
-
- return $stats{$file} if $file;
- 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 = $codes{$tag_info->{type}};
- my $severity = $type_to_sev{$tag_info->{type}};
- $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}, $sev_to_color[$severity]);
- } elsif ($color eq 'html') {
- $output .= colored_html($tag_info->{tag}, $sev_to_color[$severity]);
- } else {
- $output .= $tag_info->{tag};
- }
- $output .= "$extra\n";
-
- print $output;
-}
-
-sub print_tag_new {
- my ( $pkg_info, $tag_info, $information ) = @_;
-
- my $extra = '';
- $extra = " @$information" if @$information;
- $extra = '' if $extra eq ' ';
- my $code = $sev_to_code[$tag_info->{severity}];
- $code = 'X' if exists $tag_info->{experimental};
- $code = 'O' if $tag_info->{overridden}{override};
- my $qualifier = $sig_to_qualifier[$tag_info->{significance}];
- $qualifier = '' if $code eq 'O';
- my $type = '';
- $type = " $pkg_info->{type}" if $pkg_info->{type} ne 'binary';
-
- my $output = "$code$qualifier: $pkg_info->{pkg}$type: ";
- if ($color eq 'always' || ($color eq 'auto' && -t STDOUT)) {
- $output .= colored($tag_info->{tag}, $sev_to_color[$tag_info->{severity}]);
- } else {
- $output .= $tag_info->{tag};
- }
- $output .= "$extra\n";
-
- print $output;
-
-}
-
-sub tag {
- my ( $tag, @information ) = @_;
- unless ($current) {
- warn "Tried to issue tag $tag without setting package\n";
- return 0;
- }
-
- # Newlines in @information would cause problems, so replace them with \n.
- @information = map { s,\n,\\n,; $_ } @information;
-
- my $tag_info = get_tag_info( $tag );
- unless ($tag_info) {
- warn "Tried to issue unknown tag $tag\n";
- return 0;
- }
- check_need_to_show( $tag_info, \@information );
-
- record_stats( $tag_info );
-
- return 0 if
- exists $tag_info->{experimental} and !$show_experimental;
-
- return 1 if
- $tag_info->{overridden}{severity} != 0
- || $tag_info->{overridden}{significance} != 0
- || ( $tag_info->{overridden}{override} &&
- !$show_overrides);
-
- &$output_formatter( $info{$current}, $tag_info, \@information );
- return 1;
-}
-
-1;
-
-# Local Variables:
-# indent-tabs-mode: t
-# cperl-indent-level: 4
-# End:
-# vim: ts=4 sw=4 noet
projects / maemian / blobdiff