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

   1 # Tags -- Perl tags functions for lintian
   2
   3 # Copyright (C) 1998-2004 Various authors
   4 # Copyright (C) 2005 Frank Lichtenheld <frank@lichtenheld.de>
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, you can find it on the World Wide
  18 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  19 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  20 # MA 02110-1301, USA.
  21
  22 package Tags;
  23 use strict;
  24 use warnings;
  25
  26 use Exporter;
  27 our @ISA    = qw(Exporter);
  28 our @EXPORT = qw(tag);
  29
  30 use Lintian::Output;
  31
  32 # configuration variables and defaults
  33 our $show_pedantic = 0;
  34 our $show_experimental = 0;
  35 our $show_overrides = 0;
  36 our %display_level;
  37 our %display_source;
  38 our %only_issue_tags;
  39
  40 # The master hash with all tag info. Key is the tag name, value another hash
  41 # with the following keys:
  42 # - tag: short name
  43 # - info: Description in HTML
  44 # - ref: Any references
  45 # - experimental: experimental status (possibly undef)
  46 my %tags;
  47
  48 # Statistics per file. Key is the filename, value another hash with the
  49 # following keys:
  50 # - overrides
  51 # - tags
  52 # - types
  53 my %stats;
  54
  55 # Info about a specific file. Key is the the filename, value another hash
  56 # with the following keys:
  57 # - pkg: package name
  58 # - version: package version
  59 # - arch: package architecture
  60 # - type: one of 'binary', 'udeb' or 'source'
  61 # - overrides: hash with all overrides for this file as keys
  62 my %info;
  63
  64 # Currently selected file (not package!)
  65 my $current;
  66
  67 # Possible Severity: and Certainty: values, sorted from lowest to highest.
  68 our @severity_list = qw(pedantic wishlist minor normal important serious);
  69 our @certainty_list = qw(wild-guess possible certain);
  70
  71 # Map Severity/Certainty levels to E|W|I codes.
  72 my %codes = (
  73     'pedantic'  => { 'wild-guess' => 'P', 'possible' => 'P', 'certain' => 'P' },
  74     'wishlist'  => { 'wild-guess' => 'I', 'possible' => 'I', 'certain' => 'I' },
  75     'minor'     => { 'wild-guess' => 'I', 'possible' => 'I', 'certain' => 'W' },
  76     'normal'    => { 'wild-guess' => 'I', 'possible' => 'W', 'certain' => 'W' },
  77     'important' => { 'wild-guess' => 'W', 'possible' => 'E', 'certain' => 'E' },
  78     'serious'   => { 'wild-guess' => 'E', 'possible' => 'E', 'certain' => 'E' },
  79 );
  80
  81 # Add a new tag, supplied as a hash reference
  82 sub add_tag {
  83         my $newtag = shift;
  84         if (exists $tags{$newtag->{tag}}) {
  85             warn "Duplicate tag: $newtag->{tag}\n";
  86             return 0;
  87         }
  88
  89         $tags{$newtag->{'tag'}} = $newtag;
  90         return 1;
  91 }
  92
  93 # Add another file, will fail if there is already stored info about
  94 # the file
  95 sub set_pkg {
  96     my ( $file, $pkg, $version, $arch, $type ) = @_;
  97
  98     if (exists $info{$file}) {
  99         warn "File $file was already processed earlier\n";
 100         return 0;
 101     }
 102
 103     $info{$file} = {
 104         file => $file,
 105         pkg => $pkg,
 106         version => $version,
 107         arch => $arch,
 108         type => $type,
 109         overrides => {},
 110     };
 111     $stats{$file} = {
 112         types => {},
 113         tags => {},
 114         overrides => {},
 115     };
 116
 117     select_pkg($file);
 118     return 1;
 119 }
 120
 121 # select another file as 'current' without deleting or adding any information
 122 # the file must have been added with add_pkg
 123 sub select_pkg {
 124     my ( $file ) = @_;
 125
 126     unless (exists $info{$file}) {
 127         warn "Can't select package $file";
 128         return 0;
 129     }
 130
 131     if ($current) {
 132         $Lintian::Output::GLOBAL->print_end_pkg($info{$current});
 133     }
 134     $current = $file;
 135     if ($file !~ /.changes$/) {
 136         $Lintian::Output::GLOBAL->print_start_pkg($info{$current});
 137     }
 138     return 1;
 139 }
 140
 141 # only delete the value of 'current' without deleting any stored information
 142 sub reset_pkg {
 143     if ($current) {
 144         $Lintian::Output::GLOBAL->print_end_pkg($info{$current});
 145     }
 146     undef $current;
 147     return 1;
 148 }
 149
 150 # delete all the stored information (including tags)
 151 sub reset {
 152     undef %stats;
 153     undef %info;
 154     undef %tags;
 155     undef $current;
 156     return 1;
 157 }
 158
 159 # Add an override. If you specifiy two arguments, the first will be taken
 160 # as file to add the override to, otherwise 'current' will be assumed
 161 sub add_override {
 162     my ($tag, $extra, $file) = ( "", "", "" );
 163     if (@_ > 2) {
 164         ($file, $tag, $extra) = @_;
 165     } else {
 166         ($file, $tag, $extra) = ($current, @_);
 167     }
 168     $extra ||= "";
 169
 170     unless ($file) {
 171         warn "Don't know which package to add override $tag to";
 172         return 0;
 173     }
 174
 175     $info{$file}{overrides}{$tag}{$extra} = 0;
 176
 177     return 1;
 178 }
 179
 180 sub get_overrides {
 181     my ($file) = @_;
 182
 183     unless ($file) {
 184         warn "Don't know which package to get overrides from";
 185         return undef;
 186     }
 187
 188     return $info{$file}{overrides};
 189 }
 190
 191 # Get the info hash for a tag back as a reference. The hash will be
 192 # copied first so that you can edit it safely
 193 sub get_tag_info {
 194     my ( $tag ) = @_;
 195     return { %{$tags{$tag}} } if exists $tags{$tag};
 196     return undef;
 197 }
 198
 199 # Returns the E|W|I code for a given tag.
 200 sub get_tag_code {
 201     my ( $tag_info ) = @_;
 202     return $codes{$tag_info->{severity}}{$tag_info->{certainty}};
 203 }
 204
 205 sub add_overrides {
 206     my ($file, $pkg, $long_type) = @_;
 207
 208     if (!open(O, '<', $file)) {
 209         warn "Could not open override file '$file' for reading";
 210         return 0;
 211     }
 212
 213     local $_;
 214     while (<O>) {
 215         chomp;
 216         next if m,^\s*(\#|\z),o;
 217         s/^\s+//o;
 218         s/\s+$//o;
 219         s/\s+/ /go;
 220         my $override = $_;
 221         $override =~ s/^\Q$pkg\E( \Q$long_type\E)?: //;
 222         if ($override eq '' or $override !~ /^[\w.+-]+(\s.*)?$/) {
 223             tag ('malformed-override', $_);
 224         } else {
 225             my ($tag, $extra) = split(/ /, $override, 2);
 226             add_override($tag, $extra);
 227         }
 228     }
 229     close(O);
 230
 231     return 1;
 232 }
 233
 234 # check if a certain tag has a override for the 'current' package
 235 sub check_overrides {
 236     my ( $tag_info, $information ) = @_;
 237
 238     my $tag = $tag_info->{tag};
 239     my $overrides = $info{$current}{overrides}{$tag};
 240     return unless $overrides;
 241
 242     if( exists $overrides->{''} ) {
 243         $overrides->{''}++;
 244         return $tag;
 245     } elsif( $information ne '' and exists $overrides->{$information} ) {
 246         $overrides->{$information}++;
 247         return "$tag $information";
 248     } elsif ( $information ne '' ) {
 249         foreach (keys %$overrides) {
 250             my $regex = $_;
 251             if (m/^\*/ or m/\*$/) {
 252                 my ($start, $end) = ("","");
 253                 $start = '.*' if $regex =~ s/^\*//;
 254                 $end   = '.*' if $regex =~ s/\*$//;
 255                 if ($information =~ /^$start\Q$regex\E$end$/) {
 256                     $overrides->{$_}++;
 257                     return "$tag $_";
 258                 }
 259             }
 260         }
 261     }
 262
 263     return '';
 264 }
 265
 266 # sets all the overridden fields of a tag_info hash correctly
 267 sub set_overrides {
 268     my ( $tag_info, $information ) = @_;
 269     $tag_info->{overridden}{override} = check_overrides( $tag_info,
 270                                                          $information );
 271 }
 272
 273 # records the stats for a given tag_info hash
 274 sub record_stats {
 275     my ( $tag_info ) = @_;
 276
 277     if ($tag_info->{overridden}{override}) {
 278         $stats{$current}{overrides}{tags}{$tag_info->{overridden}{override}}++;
 279         $stats{$current}{overrides}{severity}{$tag_info->{severity}}++;
 280         $stats{$current}{overrides}{certainty}{$tag_info->{certainty}}++;
 281         $stats{$current}{overrides}{types}{get_tag_code($tag_info)}++;
 282     } else {
 283         $stats{$current}{tags}{$tag_info->{tag}}++;
 284         $stats{$current}{severity}{$tag_info->{severity}}++;
 285         $stats{$current}{certainty}{$tag_info->{certainty}}++;
 286         $stats{$current}{types}{get_tag_code($tag_info)}++;
 287     }
 288 }
 289
 290 # get the statistics for a file (one argument) or for all files (no argument)
 291 sub get_stats {
 292     my ( $file ) = @_;
 293
 294     return $stats{$file} if $file;
 295     return \%stats;
 296 }
 297
 298 # Extract manual sources from a given tag. Returns a hash that has manual
 299 # names as keys and sections/ids has values.
 300 sub get_tag_source {
 301     my ( $tag_info ) = @_;
 302     my $ref = $tag_info->{'ref'};
 303     return undef if not $ref;
 304
 305     my @refs = split(',', $ref);
 306     my %source = ();
 307     foreach my $r (@refs) {
 308         $source{$1} = $2 if $r =~ /^([\w-]+)\s(.+)$/;
 309     }
 310     return \%source;
 311 }
 312
 313 # Checks if the Severity/Certainty level of a given tag passes the threshold
 314 # of requested tags (returns 1) or not (returns 0). If there are restrictions
 315 # by source, references will be also checked. The result is also saved in the
 316 # tag structure to avoid unnecessarily checking later.
 317 sub display_tag {
 318     my ( $tag_info ) = @_;
 319     return $tag_info->{'display'} if defined $tag_info->{'display'};
 320
 321     my $severity = $tag_info->{'severity'};
 322     my $certainty = $tag_info->{'certainty'};
 323     my $level;
 324
 325     # Pedantic is just a pseudo severity, skip level checks
 326     if ($severity eq 'pedantic') {
 327         $level = 1 ;
 328     } elsif ($severity and $certainty) {
 329         $level = $display_level{$severity}{$certainty};
 330     } else {
 331         # Shouldn't happen, but avoid Perl warnings anyway.
 332         $level = 1;
 333     }
 334
 335
 336     $tag_info->{'display'} = $level;
 337     return $level if not keys %display_source;
 338
 339     my $tag_source = get_tag_source($tag_info);
 340     my %in = map { $_ => 1 } grep { $tag_source->{$_} } keys %display_source;
 341
 342     $tag_info->{'display'} = ($level and keys %in) ? 1 : 0;
 343     return $tag_info->{'display'};
 344 }
 345
 346 sub skip_print {
 347     my ( $tag_info ) = @_;
 348     return 1 if exists $tag_info->{experimental} && !$show_experimental;
 349     return 1 if $tag_info->{severity} eq 'pedantic' && !$show_pedantic;
 350     return 1 if $tag_info->{overridden}{override} && !$show_overrides;
 351     return 1 if not display_tag( $tag_info );
 352     return 0;
 353 }
 354
 355 sub tag {
 356     my ( $tag, @information ) = @_;
 357     unless ($current) {
 358         warn "Tried to issue tag $tag without setting package\n";
 359         return 0;
 360     }
 361
 362     return 0 unless
 363         ! keys %only_issue_tags or exists $only_issue_tags{$tag};
 364
 365     # Clean up @information and collapse it to a string.  Lintian code doesn't
 366     # treat the distinction between extra arguments to tag() as significant,
 367     # so we may as well take care of this up front.
 368     @information = grep { defined($_) and $_ ne '' }
 369         map { s,\n,\\n,; $_ } @information;
 370     my $information = join(' ', @information);
 371     $information = '' unless defined $information;
 372
 373     my $tag_info = get_tag_info( $tag );
 374     unless ($tag_info) {
 375         warn "Tried to issue unknown tag $tag\n";
 376         return 0;
 377     }
 378
 379     set_overrides( $tag_info, $information );
 380
 381     record_stats( $tag_info );
 382
 383     return 1 if skip_print( $tag_info );
 384
 385     $Lintian::Output::GLOBAL->print_tag( $info{$current}, $tag_info,
 386                                          $information );
 387     return 1;
 388 }
 389
 390 1;
 391
 392 # Local Variables:
 393 # indent-tabs-mode: t
 394 # cperl-indent-level: 4
 395 # End:
 396 # vim: ts=4 sw=4 noet