1 # Tags -- Perl tags functions for maemian
3 # Copyright (C) 1998-2004 Various authors
4 # Copyright (C) 2005 Frank Lichtenheld <frank@lichtenheld.de>
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.
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.
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,
27 our @ISA = qw(Exporter);
28 our @EXPORT = qw(tag);
32 # configuration variables and defaults
33 our $show_pedantic = 0;
34 our $show_experimental = 0;
35 our $show_overrides = 0;
40 # The master hash with all tag info. Key is the tag name, value another hash
41 # with the following keys:
43 # - info: Description in HTML
44 # - ref: Any references
45 # - experimental: experimental status (possibly undef)
48 # Statistics per file. Key is the filename, value another hash with the
55 # Info about a specific file. Key is the the filename, value another hash
56 # with the following keys:
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
64 # Currently selected file (not package!)
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);
71 # Map Severity/Certainty levels to E|W|I 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' },
81 # Add a new tag, supplied as a hash reference
84 if (exists $tags{$newtag->{tag}}) {
85 warn "Duplicate tag: $newtag->{tag}\n";
89 $tags{$newtag->{'tag'}} = $newtag;
93 # Add another file, will fail if there is already stored info about
96 my ( $file, $pkg, $version, $arch, $type ) = @_;
98 if (exists $info{$file}) {
99 warn "File $file was already processed earlier\n";
121 # select another file as 'current' without deleting or adding any information
122 # the file must have been added with add_pkg
126 unless (exists $info{$file}) {
127 warn "Can't select package $file";
132 $Maemian::Output::GLOBAL->print_end_pkg($info{$current});
135 if ($file !~ /.changes$/) {
136 $Maemian::Output::GLOBAL->print_start_pkg($info{$current});
141 # only delete the value of 'current' without deleting any stored information
144 $Maemian::Output::GLOBAL->print_end_pkg($info{$current});
150 # delete all the stored information (including tags)
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
162 my ($tag, $extra, $file) = ( "", "", "" );
164 ($file, $tag, $extra) = @_;
166 ($file, $tag, $extra) = ($current, @_);
171 warn "Don't know which package to add override $tag to";
175 $info{$file}{overrides}{$tag}{$extra} = 0;
184 warn "Don't know which package to get overrides from";
188 return $info{$file}{overrides};
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
195 return { %{$tags{$tag}} } if exists $tags{$tag};
199 # Returns the E|W|I code for a given tag.
201 my ( $tag_info ) = @_;
202 return $codes{$tag_info->{severity}}{$tag_info->{certainty}};
206 my ($file, $pkg, $long_type) = @_;
208 if (!open(O, '<', $file)) {
209 warn "Could not open override file '$file' for reading";
216 next if m,^\s*(\#|\z),o;
221 $override =~ s/^\Q$pkg\E( \Q$long_type\E)?: //;
222 if ($override eq '' or $override !~ /^[\w.+-]+(\s.*)?$/) {
223 tag ('malformed-override', $_);
225 my ($tag, $extra) = split(/ /, $override, 2);
226 add_override($tag, $extra);
234 # check if a certain tag has a override for the 'current' package
235 sub check_overrides {
236 my ( $tag_info, $information ) = @_;
238 my $tag = $tag_info->{tag};
239 my $overrides = $info{$current}{overrides}{$tag};
240 return unless $overrides;
242 if( exists $overrides->{''} ) {
245 } elsif( $information ne '' and exists $overrides->{$information} ) {
246 $overrides->{$information}++;
247 return "$tag $information";
248 } elsif ( $information ne '' ) {
249 foreach (keys %$overrides) {
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$/) {
266 # sets all the overridden fields of a tag_info hash correctly
268 my ( $tag_info, $information ) = @_;
269 $tag_info->{overridden}{override} = check_overrides( $tag_info,
273 # records the stats for a given tag_info hash
275 my ( $tag_info ) = @_;
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)}++;
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)}++;
290 # get the statistics for a file (one argument) or for all files (no argument)
294 return $stats{$file} if $file;
298 # Extract manual sources from a given tag. Returns a hash that has manual
299 # names as keys and sections/ids has values.
301 my ( $tag_info ) = @_;
302 my $ref = $tag_info->{'ref'};
303 return undef if not $ref;
305 my @refs = split(',', $ref);
307 foreach my $r (@refs) {
308 $source{$1} = $2 if $r =~ /^([\w-]+)\s(.+)$/;
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.
318 my ( $tag_info ) = @_;
319 return $tag_info->{'display'} if defined $tag_info->{'display'};
321 my $severity = $tag_info->{'severity'};
322 my $certainty = $tag_info->{'certainty'};
325 # Pedantic is just a pseudo severity, skip level checks
326 if ($severity eq 'pedantic') {
328 } elsif ($severity and $certainty) {
329 $level = $display_level{$severity}{$certainty};
331 # Shouldn't happen, but avoid Perl warnings anyway.
336 $tag_info->{'display'} = $level;
337 return $level if not keys %display_source;
339 my $tag_source = get_tag_source($tag_info);
340 my %in = map { $_ => 1 } grep { $tag_source->{$_} } keys %display_source;
342 $tag_info->{'display'} = ($level and keys %in) ? 1 : 0;
343 return $tag_info->{'display'};
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 );
356 my ( $tag, @information ) = @_;
358 warn "Tried to issue tag $tag without setting package\n";
363 ! keys %only_issue_tags or exists $only_issue_tags{$tag};
365 # Clean up @information and collapse it to a string. Maemian 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;
373 my $tag_info = get_tag_info( $tag );
375 warn "Tried to issue unknown tag $tag\n";
379 set_overrides( $tag_info, $information );
381 record_stats( $tag_info );
383 return 1 if skip_print( $tag_info );
385 $Maemian::Output::GLOBAL->print_tag( $info{$current}, $tag_info,