vcs.maemo.org Git - maemian/blob - nokia-lintian/lib/Tags.pm

   1 # Tags -- Perl tags functions for lintian
   2 # $Id$
   3
   4 # Copyright (C) 1998-2004 Various authors
   5 # Copyright (C) 2005 Frank Lichtenheld <frank@lichtenheld.de>
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 2 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, you can find it on the World Wide
  19 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  20 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  21 # MA 02110-1301, USA.
  22
  23 package Tags;
  24 use strict;
  25 use warnings;
  26
  27 use Exporter;
  28 our @ISA    = qw(Exporter);
  29 our @EXPORT = qw(tag);
  30
  31 # support for ANSI color output via colored()
  32 use Term::ANSIColor;
  33
  34 # Quiet "Name "main::LINTIAN_ROOT" used only once"
  35 # The variables comes from 'lintian'
  36 () = ($main::verbose, $main::debug);
  37
  38 # configuration variables and defaults
  39 our $verbose = $::verbose;
  40 our $debug = $::debug;
  41 our $show_info = 0;
  42 our $show_experimental = 0;
  43 our $show_overrides = 0;
  44 our $output_formatter = \&print_tag;
  45 our $min_severity = 1;
  46 our $max_severity = 99;
  47 our $min_significance = 1;
  48 our $max_significance = 99;
  49 our $color = 'never';
  50
  51 # The master hash with all tag info. Key is the tag name, value another hash
  52 # with the following keys:
  53 # - tag: short name
  54 # - type: error/warning/info/experimental
  55 # - info: Description in HTML
  56 # - ref: Any references
  57 # - experimental: experimental status (possibly undef)
  58 my %tags;
  59
  60 # Statistics per file. Key is the filename, value another hash with the
  61 # following keys:
  62 # - overrides
  63 # - tags
  64 # - severity
  65 # - significance
  66 my %stats;
  67
  68 # Info about a specific file. Key is the the filename, value another hash
  69 # with the following keys:
  70 # - pkg: package name
  71 # - version: package version
  72 # - arch: package architecture
  73 # - type: one of 'binary', 'udeb' or 'source'
  74 # - overrides: hash with all overrides for this file as keys
  75 my %info;
  76
  77 # Currently selected file (not package!)
  78 my $current;
  79
  80 # Compatibility stuff
  81 my %codes = ( 'error' => 'E' , 'warning' => 'W' , 'info' => 'I' );
  82 our %type_to_sev = ( error => 4, warning => 2, info => 0 );
  83 our @sev_to_type = qw( info warning warning error error );
  84
  85 my @sig_to_qualifier = ( '??', '?', '', '!' );
  86 my @sev_to_code = qw( I W W E E );
  87 my @sev_to_color = ( 'cyan', 'yellow', 'yellow', 'red', 'red' );
  88
  89 # Add a new tag, supplied as a hash reference
  90 sub add_tag {
  91         my $newtag = shift;
  92         if (exists $tags{$newtag->{tag}}) {
  93             warn "Duplicate tag: $newtag->{tag}\n";
  94             return 0;
  95         }
  96
  97         # smooth transition
  98         $newtag->{type} = $sev_to_type[$newtag->{severity}]
  99             unless $newtag->{type};
 100         $newtag->{significance} = 2 unless exists $newtag->{significance};
 101         $newtag->{severity} = $type_to_sev{$newtag->{type}}
 102             unless exists $newtag->{severity};
 103         $tags{$newtag->{'tag'}} = $newtag;
 104         return 1;
 105 }
 106
 107 # Add another file, will fail if there is already stored info about
 108 # the file
 109 sub set_pkg {
 110     my ( $file, $pkg, $version, $arch, $type ) = @_;
 111
 112     if (exists $info{$file}) {
 113         warn "File $file was already processed earlier\n";
 114         return 0;
 115     }
 116
 117     $current = $file;
 118     $info{$file} = {
 119         pkg => $pkg,
 120         version => $version,
 121         arch => $arch,
 122         type => $type,
 123         overrides => {},
 124     };
 125     $stats{$file} = {
 126         severity => {},
 127         significance => {},
 128         tags => {},
 129         overrides => {},
 130     };
 131
 132     return 1;
 133 }
 134
 135 # select another file as 'current' without deleting or adding any information
 136 # the file must have been added with add_pkg
 137 sub select_pkg {
 138     my ( $file ) = @_;
 139
 140     unless (exists $info{$file}) {
 141         warn "Can't select package $file";
 142         return 0;
 143     }
 144
 145     $current = $file;
 146     return 1;
 147 }
 148
 149 # only delete the value of 'current' without deleting any stored information
 150 sub reset_pkg {
 151     undef $current;
 152     return 1;
 153 }
 154
 155 # delete all the stored information (including tags)
 156 sub reset {
 157     undef %stats;
 158     undef %info;
 159     undef %tags;
 160     undef $current;
 161     return 1;
 162 }
 163
 164 # Add an override. If you specifiy two arguments, the first will be taken
 165 # as file to add the override to, otherwise 'current' will be assumed
 166 sub add_override {
 167     my ($tag, $file) = ( "", "" );
 168     if (@_ > 1) {
 169         ($file, $tag) = @_;
 170     } else {
 171         ($file, $tag) = ($current, @_);
 172     }
 173
 174     unless ($file) {
 175         warn "Don't know which package to add override $tag to";
 176         return 0;
 177     }
 178
 179     $info{$file}{overrides}{$tag} = 0;
 180
 181     return 1;
 182 }
 183
 184 sub get_overrides {
 185     my ($file) = @_;
 186
 187     unless ($file) {
 188         warn "Don't know which package to get overrides from";
 189         return undef;
 190     }
 191
 192     return $info{$file}{overrides};
 193 }
 194
 195 # Get the info hash for a tag back as a reference. The hash will be
 196 # copied first so that you can edit it safely
 197 sub get_tag_info {
 198     my ( $tag ) = @_;
 199     return { %{$tags{$tag}} } if exists $tags{$tag};
 200     return undef;
 201 }
 202
 203 sub check_range {
 204     my ( $x, $min, $max ) = @_;
 205
 206     return -1 if $x < $min;
 207     return 1 if $x > $max;
 208     return 0;
 209 }
 210
 211 # check if a certain tag has a override for the 'current' package
 212 sub check_overrides {
 213     my ( $tag_info, $information ) = @_;
 214
 215     my $extra = '';
 216     $extra = " @$information" if @$information;
 217     $extra = '' if $extra eq ' ';
 218     if( exists $info{$current}{overrides}{$tag_info->{tag}}) {
 219         $info{$current}{overrides}{$tag_info->{tag}}++;
 220         return $tag_info->{tag};
 221     } elsif( exists $info{$current}{overrides}{"$tag_info->{tag}$extra"} ) {
 222         $info{$current}{overrides}{"$tag_info->{tag}$extra"}++;
 223         return "$tag_info->{tag}$extra";
 224     }
 225
 226     return '';
 227 }
 228
 229 # sets all the overridden fields of a tag_info hash correctly
 230 sub check_need_to_show {
 231     my ( $tag_info, $information ) = @_;
 232     $tag_info->{overridden}{override} = check_overrides( $tag_info,
 233                                                          $information );
 234     my $min_sev = $show_info ? 0 : $min_severity; # compat hack
 235     $tag_info->{overridden}{severity} = check_range( $tag_info->{severity},
 236                                                      $min_sev,
 237                                                      $max_severity );
 238     $tag_info->{overridden}{significance} = check_range( $tag_info->{significance},
 239                                                          $min_significance,
 240                                                          $max_significance );
 241 }
 242
 243 # records the stats for a given tag_info hash
 244 sub record_stats {
 245     my ( $tag_info ) = @_;
 246
 247     for my $k (qw( severity significance tag )) {
 248         $stats{$current}{$k}{$tag_info->{$k}}++
 249             unless $tag_info->{overridden}{override}
 250                 || $tag_info->{overridden}{severity}
 251                 || $tag_info->{overridden}{significance};
 252     }
 253     for my $k (qw( severity significance override )) {
 254         $stats{$current}{overrides}{$k}{$tag_info->{overridden}{$k}}++
 255             if $tag_info->{overridden}{$k};
 256     }
 257     if ($tag_info->{overridden}{override}) {
 258         $stats{$current}{overrides}{by_severity}{$tag_info->{severity}}++;
 259     }
 260 }
 261
 262 # get the statistics for a file (one argument) or for all files (no argument)
 263 sub get_stats {
 264     my ( $file ) = @_;
 265
 266     return $stats{$file} if $file;
 267     return \%stats;
 268 }
 269
 270 # Color tags with HTML.  Takes the tag and the color name.
 271 sub colored_html {
 272     my ($tag, $color) = @_;
 273     return qq(<span style="color: $color">$tag</span>);
 274 }
 275
 276 sub print_tag {
 277     my ( $pkg_info, $tag_info, $information ) = @_;
 278
 279     my $extra = '';
 280     $extra = " @$information" if @$information;
 281     $extra = '' if $extra eq ' ';
 282     my $code = $codes{$tag_info->{type}};
 283     my $severity = $type_to_sev{$tag_info->{type}};
 284     $code = 'X' if exists $tag_info->{experimental};
 285     $code = 'O' if $tag_info->{overridden}{override};
 286     my $type = '';
 287     $type = " $pkg_info->{type}" if $pkg_info->{type} ne 'binary';
 288
 289     my $output = "$code: $pkg_info->{pkg}$type: ";
 290     if ($color eq 'always' || ($color eq 'auto' && -t STDOUT)) {
 291         $output .= colored($tag_info->{tag}, $sev_to_color[$severity]);
 292     } elsif ($color eq 'html') {
 293         $output .= colored_html($tag_info->{tag}, $sev_to_color[$severity]);
 294     } else {
 295         $output .= $tag_info->{tag};
 296     }
 297     $output .= "$extra\n";
 298
 299     print $output;
 300 }
 301
 302 sub print_tag_new {
 303     my ( $pkg_info, $tag_info, $information ) = @_;
 304
 305     my $extra = '';
 306     $extra = " @$information" if @$information;
 307     $extra = '' if $extra eq ' ';
 308     my $code = $sev_to_code[$tag_info->{severity}];
 309     $code = 'X' if exists $tag_info->{experimental};
 310     $code = 'O' if $tag_info->{overridden}{override};
 311     my $qualifier = $sig_to_qualifier[$tag_info->{significance}];
 312     $qualifier = '' if $code eq 'O';
 313     my $type = '';
 314     $type = " $pkg_info->{type}" if $pkg_info->{type} ne 'binary';
 315
 316     my $output = "$code$qualifier: $pkg_info->{pkg}$type: ";
 317     if ($color eq 'always' || ($color eq 'auto' && -t STDOUT)) {
 318         $output .= colored($tag_info->{tag}, $sev_to_color[$tag_info->{severity}]);
 319     } else {
 320         $output .= $tag_info->{tag};
 321     }
 322     $output .= "$extra\n";
 323
 324     print $output;
 325
 326 }
 327
 328 sub tag {
 329     my ( $tag, @information ) = @_;
 330     unless ($current) {
 331         warn "Tried to issue tag $tag without setting package\n";
 332         return 0;
 333     }
 334
 335     # Newlines in @information would cause problems, so replace them with \n.
 336     @information = map { s,\n,\\n,; $_ } @information;
 337
 338     my $tag_info = get_tag_info( $tag );
 339     unless ($tag_info) {
 340         warn "Tried to issue unknown tag $tag\n";
 341         return 0;
 342     }
 343     check_need_to_show( $tag_info, \@information );
 344
 345     record_stats( $tag_info );
 346
 347     return 0 if
 348         exists $tag_info->{experimental} and !$show_experimental;
 349
 350     return 1 if
 351         $tag_info->{overridden}{severity} != 0
 352         || $tag_info->{overridden}{significance} != 0
 353         || ( $tag_info->{overridden}{override} &&
 354              !$show_overrides);
 355
 356     &$output_formatter( $info{$current}, $tag_info, \@information );
 357     return 1;
 358 }
 359
 360 1;
 361
 362 # Local Variables:
 363 # indent-tabs-mode: t
 364 # cperl-indent-level: 4
 365 # End:
 366 # vim: ts=4 sw=4 noet