X-Git-Url: https://git.donarmstrong.com/?p=bugscan.git;a=blobdiff_plain;f=scanlib.pm;h=9bd84581e59d1292a3dfd49662a91e2362ebfa83;hp=2b905c43996d3991c1710e09e1569c5d03757c38;hb=ba928af3f693d3d4fc348c4d1395967fbddd04b1;hpb=038c6aa61e809657e74971f8fe72a56fe57551a7 diff --git a/scanlib.pm b/scanlib.pm index 2b905c4..9bd8458 100644 --- a/scanlib.pm +++ b/scanlib.pm @@ -1,20 +1,16 @@ #! /usr/bin/perl -# vim: ts=4 sw=4 nowrap +# vim: ts=8 sw=8 nowrap # # General functions for scanning the BTS-database. # Based on bugscan, written by Richard Braakman , # which was based on an unknown other script. # # Global variables: -# %comments - map from bugnumber to bug description -# %premature - list of prematurely closed bugreports -# %exclude - list of bugreports to exclude from the report # %maintainer - map from packagename to maintainer # %section - map from packagename to section in the FTP-site # %packagelist - map from packagename to bugreports -# %NMU - map with NMU information -use lib qw(/org/bugs.debian.org/perl/); +use lib qw(/org/bugs.debian.org/perl); use LWP::UserAgent; use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522); use Debbugs::Packages; @@ -26,43 +22,7 @@ use warnings; require bugcfg; package scanlib; -our (%comments,%premature,%exclude,%maintainer,%section,%packagelist,%NMU,%debbugssection,%bugs); - -sub readcomments() { -# Read bug commentary -# It is in paragraph format, with the first line of each paragraph being -# the bug number or package name to which the comment applies. -# Prefix a bug number with a * to force it to be listed even if it's closed. -# (This deals with prematurely closed bugs) - - my $index; # Bug-number for current comment - my $file; # Name of comments-file - - %comments = (); # Initialize our data - %premature = (); - %exclude = (); - $file=shift; - open(C, $file) or die "open $file: $!\n"; - while () { - chomp; - if (m/^\s*$/) { # Check for paragraph-breaks - undef $index; - } elsif (defined $index) { - $comments{$index} .= $_ . "\n"; - } else { - if (s/^\*//) { # Test & remove initial * - $premature{$_} = 1; - } - if (s/\s+EXCLUDE\s*//) { # Test & remove EXCLUDE - $exclude{$_} = 1; - next; - } - $index = $_; - $comments{$index} = ''; # New comment, initialize data - } - } - close(C); -} +our (%maintainer,%section,%packagelist,%debbugssection,%bugs); # Read the list of maintainer @@ -191,11 +151,15 @@ sub scanspooldir() { closedir(DIR); for $f (@list) { - next if $exclude{$f}; # Check the list of bugs to skip - my $bug = Debbugs::Status::read_bug(summary => "$f.summary"); next if (!defined($bug)); + my $bi = { + number => $f, + subject => $bug->{'subject'}, + package => $bug->{'package'} + }; + $skip=1; for $walk (@bugcfg::priorities) { $skip=0 if $walk eq $bug->{'severity'}; @@ -208,47 +172,62 @@ sub scanspooldir() { } } next if $skip==1; + + my %disttags = (); + $disttags{'oldstable'} = grep(/^sarge$/, @tags); + $disttags{'stable'} = grep(/^etch$/, @tags); + $disttags{'testing'} = grep(/^lenny$/, @tags); + $disttags{'unstable'} = grep(/^sid$/, @tags); + $disttags{'experimental'} = grep(/^experimental$/, @tags); + + # default according to vorlon 2007-06-17 + if (!$disttags{'oldstable'} && !$disttags{'stable'} && !$disttags{'testing'} && !$disttags{'unstable'} && !$disttags{'experimental'}) { + $disttags{'stable'} = 1; + $disttags{'testing'} = 1; + $disttags{'unstable'} = 1; + $disttags{'experimental'} = 1; + } + + if (defined($section{$bug->{'package'}}) && $section{$bug->{'package'}} eq 'pseudo') { + # versioning information makes no sense for pseudo packages, + # just use the tags + for my $dist qw(oldstable stable testing unstable experimental) { + $bi->{$dist} = $disttags{$dist}; + } + next if (length($bug->{'done'})); + } else { + my $affects_any = 0; - my $oldstable_tag = grep(/^woody$/, @tags); - my $stable_tag = grep(/^sarge$/, @tags); - my $testing_tag = grep(/^etch$/, @tags); - my $unstable_tag = grep(/^sid$/, @tags); - my $experimental_tag = grep(/^experimental$/, @tags); - - # default according to dondelelcaro 2006-11-11 - if (!$oldstable_tag && !$stable_tag && !$testing_tag && !$unstable_tag && !$experimental_tag) { - $testing_tag = 1; - $unstable_tag = 1; - $experimental_tag = 1; + # only bother to check the versioning status for the distributions indicated by the tags + for my $dist qw(oldstable stable testing unstable experimental) { + local $SIG{__WARN__} = sub {}; + + $bi->{$dist} = 0; + next if (!$disttags{$dist}); + + my $presence = Debbugs::Status::bug_presence( + bug => $f, + status => $bug, + dist => $dist, + arch => \@bugcfg::architectures + ); + + # ignore bugs that are absent/fixed in this distribution, include everything + # else (that is, "found" which says that the bug is present, and undef, which + # indicates that no versioning information is present and it's not closed + # unversioned) + if (!defined($presence) || ($presence ne 'absent' && $presence ne 'fixed')) { + $bi->{$dist} = 1; + $affects_any = 1; + } + } + + next if !$affects_any; } - # only bother to check the versioning status for the distributions indicated by the tags - my $status_oldstable = get_status($f, $bug, 'oldstable') if ($oldstable_tag); - my $status_stable = get_status($f, $bug, 'stable') if ($stable_tag); - my $status_testing = get_status($f, $bug, 'testing') if ($testing_tag); - my $status_unstable = get_status($f, $bug, 'unstable') if ($unstable_tag); - my $status_experimental = get_status($f, $bug, 'experimental') if ($experimental_tag); - - my $relinfo = ""; - $relinfo .= (($oldstable_tag && $status_oldstable eq 'pending') ? "O" : ""); - $relinfo .= (($stable_tag && $status_stable eq 'pending') ? "S" : ""); - $relinfo .= (($testing_tag && $status_testing eq 'pending') ? "T" : ""); - $relinfo .= (($unstable_tag && $status_unstable eq 'pending') ? "U" : ""); - $relinfo .= (($experimental_tag && $status_experimental eq 'pending') ? "E" : ""); - - next if $relinfo eq '' and not $premature{$f}; - $premature{$f}++ if $relinfo eq ''; - - $taginfo = "["; - $taginfo .= ($bug->{'keywords'} =~ /\bpending\b/ ? "P" : " "); - $taginfo .= ($bug->{'keywords'} =~ /\bpatch\b/ ? "+" : " "); - $taginfo .= ($bug->{'keywords'} =~ /\bhelp\b/ ? "H" : " "); - $taginfo .= ($bug->{'keywords'} =~ /\bmoreinfo\b/ ? "M" : " "); - $taginfo .= ($bug->{'keywords'} =~ /\bunreproducible\b/ ? "R" : " "); - $taginfo .= ($bug->{'keywords'} =~ /\bsecurity\b/ ? "S" : " "); - $taginfo .= ($bug->{'keywords'} =~ /\bupstream\b/ ? "U" : " "); - $taginfo .= ($bug->{'keywords'} =~ /\betch-ignore\b/ ? "I" : " "); - $taginfo .= "]"; + for my $keyword qw(pending patch help moreinfo unreproducible security upstream etch-ignore lenny-ignore) { + $bi->{$keyword} = grep(/^$keyword$/, @tags); + } if (length($bug->{'mergedwith'})) { my @merged = split(' ', $bug->{'mergedwith'}); @@ -257,84 +236,51 @@ sub scanspooldir() { for my $package (split /[,\s]+/, $bug->{'package'}) { $_= $package; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9]/; - if (not defined $section{$_}) { - if (defined $debbugssection{$_}) { - $relinfo .= "X"; - } else { - next; # Skip unavailable packages - } - } - push @{$packagelist{$_}}, $f; } - if ($relinfo eq "") { # or $relinfo eq "U" # confuses e.g. #210306 - $relinfo = ""; - } else { - $relinfo = " [$relinfo]"; - } + my $taginfo = get_taginfo($bi); + my $relinfo = get_relinfo($bi); - $bugs{$f} = "$f $taginfo$relinfo " . $bug->{'subject'}; + $bugs{$f} = $bi; } } sub readstatus() { - my $bug; # Number of current bug - my $subject; # Subject for current bug - my $pkg; # Name of current package - my $file; # Name of statusfile - my $sect; # Section of current package - my $mnt; # Maintainer of current package - - $file=shift; - open(P, $file) or die "open $file: $!"; - while (

) { - chomp; - if (m/^[0-9]+ \[/) { - ($bug,$subject)=split(/ /, $_, 2); - $bugs{$bug}=$subject; - push @{$packagelist{$pkg}}, $bug; - } else { - ($pkg,$sect, $mnt)=split(/ /, $_, 3); - $section{$pkg}=$sect; - $maintainer{$pkg}=$mnt; + my $filename = shift; + open STATUS, "<", $filename + or die "$filename: $!"; + + while (1) { + chomp (my $type = ); + if ($type eq 'package') { + chomp (my $package = ); + chomp (my $section = ); + chomp (my $maintainer = ); + my $blank = ; + + $section{$package} = $section; + $maintainer{$package} = $maintainer; } - } - close P; -} + if ($type eq 'bug') { + my $bug = {}; + while (1) { + my $line = ; + last if ($line !~ /^(.*?)=(.*)$/); + $bug->{$1} = $2; + } + $bugs{$bug->{'number'}} = $bug; -sub readNMUstatus() { - my $bug; # Number of current bug - my $source; # Source upload which closes this bug. - my $version; # Version where this bug was closed. - my $flag; # Whether this paragraph has been processed. - my ($field, $value); - - for (split /\n/, LWP::UserAgent->new->request(HTTP::Request->new(GET => shift))->content) { - chomp; - if (m/^$/) { - $NMU{$bug} = 1; - $NMU{$bug, "source"} = $source; - $NMU{$bug, "version"} = $version; -# $comments{$bug} .= "[FIXED] Fixed package $source is in Incoming\n"; - $flag = 0; - } else { - ($field, $value) = split(/: /, $_, 2); - $bug = $value if($field =~ /bug/i); - $source = $value if($field =~ /source/i); - $version = $value if($field =~ /version/i); - $flag = 1; + for my $package (split /[,\s]+/, $bug->{'package'}) { + $_= $package; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9]/; + push @{$packagelist{$_}}, $bug->{'number'}; + } } + last if ($type eq 'end'); } - if ($flag) { - $NMU{$bug} = 1; - $NMU{$bug, "source"} = $source; - $NMU{$bug, "version"} = $version; -# $comments{$bug} .= "[FIXED] Fixed package $source in in Incoming\n"; - } - close P; + close(STATUS); } @@ -356,12 +302,9 @@ sub htmlsanit { sub wwwnumber() { my $number = shift; # Number of bug to html-ize -# my $section); # Section for the bug "' . htmlsanit($number) . ''; -# ($section=$number) =~ s/([0-9]{2}).*/$1/; -# "$number"; } sub wwwname() { @@ -369,42 +312,46 @@ sub wwwname() { "' . htmlsanit($name) . ''; -# "$name"; } -my $_version_cache = {}; -sub get_status() { - my ($bugnr, $bug, $dist) = @_; +sub check_worry { + my ($bi) = @_; - my @versions = Debbugs::Status::getversions($bug->{'package'}, $dist, undef); - my @sourceversions = Debbugs::Status::makesourceversions($bug->{'package'}, undef, @versions); + return ($bi->{'testing'} && !$bi->{'lenny-ignore'}); +} - if (length($bug->{'done'}) and - (not @sourceversions or not @{$bug->{'fixed_versions'}})) { - return 'done'; - } - if (@sourceversions) { - my $max_buggy = Debbugs::Status::max_buggy(bug => $bugnr, - sourceversions => \@sourceversions, - found => $bug->{'found_versions'}, - fixed => $bug->{'fixed_versions'}, - version_cache => $_version_cache, - package => $bug->{'package'}); - if ($max_buggy eq 'absent' || $max_buggy eq 'fixed') { - return $max_buggy; - } - } +sub check_worry_stable { + my ($bi) = @_; - return 'pending'; + return ($bi->{'stable'} && !$bi->{'etch-ignore'}); } -sub check_worry { - my ($status) = @_; +sub get_taginfo { + my $bi = shift; + + my $taginfo = ""; + $taginfo .= $bi->{'pending'} ? "P" : " "; + $taginfo .= $bi->{'patch'} ? "+" : " "; + $taginfo .= $bi->{'help'} ? "H" : " "; + $taginfo .= $bi->{'moreinfo'} ? "M" : " "; + $taginfo .= $bi->{'unreproducible'} ? "R" : " "; + $taginfo .= $bi->{'security'} ? "S" : " "; + $taginfo .= $bi->{'upstream'} ? "U" : " "; + $taginfo .= ($bi->{'etch-ignore'} || $bi->{'lenny-ignore'}) ? "I" : " "; - if ($status =~ m/^\[[^]]*I/ or - $status =~ m/ \[[^]]*X/ or - ($status =~ m/ \[[^]]*[OSUE]/ and $status !~ m/ \[[^]]*T/)) { - return 0; + return $taginfo; +} + +sub get_relinfo { + my $bi = shift; + + my $relinfo = ""; + for my $dist qw(oldstable stable testing unstable experimental) { + $relinfo .= uc(substr($dist, 0, 1)) if $bi->{$dist}; } - return 1; + + return $relinfo; } + + +1;