[SCM] Debian package checker branch, master, updated. 2.2.18-33-g3cfd89c
The following commit has been merged in the master branch:
commit 3a5d554482e10a8ee933bf25ba87d15123356c99
Author: Russ Allbery <rra@debian.org>
Date: Mon Dec 21 23:24:51 2009 -0800
Remove the old Tags module
* lib/Tags.pm:
+ [RA] Removed in favor of Lintian::Tags.
Bump the version number since this is a fairly major internal change.
diff --git a/debian/changelog b/debian/changelog
index abb8316..c6c89f4 100755
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,4 +1,4 @@
-lintian (2.2.19) UNRELEASED; urgency=low
+lintian (2.3.0) UNRELEASED; urgency=low
* checks/*:
+ [RA] Use Lintian::Tags instead of Tags.
@@ -51,6 +51,8 @@ lintian (2.2.19) UNRELEASED; urgency=low
+ [RA] Support suppressing a list of tags.
* lib/Spelling.pm:
+ [RA] Use Lintian::Tags instead of Tags.
+ * lib/Tags.pm:
+ + [RA] Removed in favor of Lintian::Tags.
* lib/Util.pm:
+ [RA] Consume all output from extracting the control file of a binary
package before closing the pipe.
diff --git a/lib/Tags.pm b/lib/Tags.pm
deleted file mode 100644
index 0053938..0000000
--- a/lib/Tags.pm
+++ /dev/null
@@ -1,398 +0,0 @@
-# Tags -- Perl tags functions for lintian
-
-# 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);
-
-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;
-our %suppress_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 (<O>) {
- 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};
- return 0 if $suppress_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,g; $_ } @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
--
Debian package checker
Reply to: