From: Jeremiah Foster Date: Thu, 28 May 2009 12:08:38 +0000 (+0300) Subject: Added the Tags.pm module, also needed for outut. X-Git-Url: https://vcs.maemo.org/git/?a=commitdiff_plain;ds=sidebyside;h=f7acfbedaeb1e8a9ff7b433c04b6059394ed5aa2;p=maemian Added the Tags.pm module, also needed for outut. --- diff --git a/lib/Tags.pm b/lib/Tags.pm new file mode 100644 index 0000000..0895221 --- /dev/null +++ b/lib/Tags.pm @@ -0,0 +1,396 @@ +# Tags -- Perl tags functions for lintian + +# Copyright (C) 1998-2004 Various authors +# Copyright (C) 2005 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 Tags; +use strict; +use warnings; + +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(tag); + +use Lintian::Output; + +# configuration variables and defaults +our $show_pedantic = 0; +our $show_experimental = 0; +our $show_overrides = 0; +our %display_level; +our %display_source; +our %only_issue_tags; + +# The master hash with all tag info. Key is the tag name, value another hash +# with the following keys: +# - tag: short name +# - 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 +# - types +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; + +# Possible Severity: and Certainty: values, sorted from lowest to highest. +our @severity_list = qw(pedantic wishlist minor normal important serious); +our @certainty_list = qw(wild-guess possible certain); + +# Map Severity/Certainty levels to E|W|I codes. +my %codes = ( + 'pedantic' => { 'wild-guess' => 'P', 'possible' => 'P', 'certain' => 'P' }, + 'wishlist' => { 'wild-guess' => 'I', 'possible' => 'I', 'certain' => 'I' }, + 'minor' => { 'wild-guess' => 'I', 'possible' => 'I', 'certain' => 'W' }, + 'normal' => { 'wild-guess' => 'I', 'possible' => 'W', 'certain' => 'W' }, + 'important' => { 'wild-guess' => 'W', 'possible' => 'E', 'certain' => 'E' }, + 'serious' => { 'wild-guess' => 'E', 'possible' => 'E', 'certain' => 'E' }, +); + +# 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; + } + + $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; + } + + $info{$file} = { + file => $file, + pkg => $pkg, + version => $version, + arch => $arch, + type => $type, + overrides => {}, + }; + $stats{$file} = { + types => {}, + tags => {}, + overrides => {}, + }; + + select_pkg($file); + 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; + } + + if ($current) { + $Lintian::Output::GLOBAL->print_end_pkg($info{$current}); + } + $current = $file; + if ($file !~ /.changes$/) { + $Lintian::Output::GLOBAL->print_start_pkg($info{$current}); + } + return 1; +} + +# only delete the value of 'current' without deleting any stored information +sub reset_pkg { + if ($current) { + $Lintian::Output::GLOBAL->print_end_pkg($info{$current}); + } + 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, $extra, $file) = ( "", "", "" ); + if (@_ > 2) { + ($file, $tag, $extra) = @_; + } else { + ($file, $tag, $extra) = ($current, @_); + } + $extra ||= ""; + + unless ($file) { + warn "Don't know which package to add override $tag to"; + return 0; + } + + $info{$file}{overrides}{$tag}{$extra} = 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; +} + +# Returns the E|W|I code for a given tag. +sub get_tag_code { + my ( $tag_info ) = @_; + return $codes{$tag_info->{severity}}{$tag_info->{certainty}}; +} + +sub add_overrides { + my ($file, $pkg, $long_type) = @_; + + if (!open(O, '<', $file)) { + warn "Could not open override file '$file' for reading"; + return 0; + } + + local $_; + while () { + chomp; + next if m,^\s*(\#|\z),o; + s/^\s+//o; + s/\s+$//o; + s/\s+/ /go; + my $override = $_; + $override =~ s/^\Q$pkg\E( \Q$long_type\E)?: //; + if ($override eq '' or $override !~ /^[\w.+-]+(\s.*)?$/) { + tag ('malformed-override', $_); + } else { + my ($tag, $extra) = split(/ /, $override, 2); + add_override($tag, $extra); + } + } + close(O); + + return 1; +} + +# check if a certain tag has a override for the 'current' package +sub check_overrides { + my ( $tag_info, $information ) = @_; + + my $tag = $tag_info->{tag}; + my $overrides = $info{$current}{overrides}{$tag}; + return unless $overrides; + + if( exists $overrides->{''} ) { + $overrides->{''}++; + return $tag; + } elsif( $information ne '' and exists $overrides->{$information} ) { + $overrides->{$information}++; + return "$tag $information"; + } elsif ( $information ne '' ) { + foreach (keys %$overrides) { + my $regex = $_; + if (m/^\*/ or m/\*$/) { + my ($start, $end) = ("",""); + $start = '.*' if $regex =~ s/^\*//; + $end = '.*' if $regex =~ s/\*$//; + if ($information =~ /^$start\Q$regex\E$end$/) { + $overrides->{$_}++; + return "$tag $_"; + } + } + } + } + + return ''; +} + +# sets all the overridden fields of a tag_info hash correctly +sub set_overrides { + my ( $tag_info, $information ) = @_; + $tag_info->{overridden}{override} = check_overrides( $tag_info, + $information ); +} + +# records the stats for a given tag_info hash +sub record_stats { + my ( $tag_info ) = @_; + + if ($tag_info->{overridden}{override}) { + $stats{$current}{overrides}{tags}{$tag_info->{overridden}{override}}++; + $stats{$current}{overrides}{severity}{$tag_info->{severity}}++; + $stats{$current}{overrides}{certainty}{$tag_info->{certainty}}++; + $stats{$current}{overrides}{types}{get_tag_code($tag_info)}++; + } else { + $stats{$current}{tags}{$tag_info->{tag}}++; + $stats{$current}{severity}{$tag_info->{severity}}++; + $stats{$current}{certainty}{$tag_info->{certainty}}++; + $stats{$current}{types}{get_tag_code($tag_info)}++; + } +} + +# 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; +} + +# Extract manual sources from a given tag. Returns a hash that has manual +# names as keys and sections/ids has values. +sub get_tag_source { + my ( $tag_info ) = @_; + my $ref = $tag_info->{'ref'}; + return undef if not $ref; + + my @refs = split(',', $ref); + my %source = (); + foreach my $r (@refs) { + $source{$1} = $2 if $r =~ /^([\w-]+)\s(.+)$/; + } + return \%source; +} + +# Checks if the Severity/Certainty level of a given tag passes the threshold +# of requested tags (returns 1) or not (returns 0). If there are restrictions +# by source, references will be also checked. The result is also saved in the +# tag structure to avoid unnecessarily checking later. +sub display_tag { + my ( $tag_info ) = @_; + return $tag_info->{'display'} if defined $tag_info->{'display'}; + + my $severity = $tag_info->{'severity'}; + my $certainty = $tag_info->{'certainty'}; + my $level; + + # Pedantic is just a pseudo severity, skip level checks + if ($severity eq 'pedantic') { + $level = 1 ; + } elsif ($severity and $certainty) { + $level = $display_level{$severity}{$certainty}; + } else { + # Shouldn't happen, but avoid Perl warnings anyway. + $level = 1; + } + + + $tag_info->{'display'} = $level; + return $level if not keys %display_source; + + my $tag_source = get_tag_source($tag_info); + my %in = map { $_ => 1 } grep { $tag_source->{$_} } keys %display_source; + + $tag_info->{'display'} = ($level and keys %in) ? 1 : 0; + return $tag_info->{'display'}; +} + +sub skip_print { + my ( $tag_info ) = @_; + return 1 if exists $tag_info->{experimental} && !$show_experimental; + return 1 if $tag_info->{severity} eq 'pedantic' && !$show_pedantic; + return 1 if $tag_info->{overridden}{override} && !$show_overrides; + return 1 if not display_tag( $tag_info ); + return 0; +} + +sub tag { + my ( $tag, @information ) = @_; + unless ($current) { + warn "Tried to issue tag $tag without setting package\n"; + return 0; + } + + return 0 unless + ! keys %only_issue_tags or exists $only_issue_tags{$tag}; + + # Clean up @information and collapse it to a string. Lintian code doesn't + # treat the distinction between extra arguments to tag() as significant, + # so we may as well take care of this up front. + @information = grep { defined($_) and $_ ne '' } + map { s,\n,\\n,; $_ } @information; + my $information = join(' ', @information); + $information = '' unless defined $information; + + my $tag_info = get_tag_info( $tag ); + unless ($tag_info) { + warn "Tried to issue unknown tag $tag\n"; + return 0; + } + + set_overrides( $tag_info, $information ); + + record_stats( $tag_info ); + + return 1 if skip_print( $tag_info ); + + $Lintian::Output::GLOBAL->print_tag( $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