X-Git-Url: https://git.donarmstrong.com/?p=bugscan.git;a=blobdiff_plain;f=scanlib.pm;h=60e4cf47837d454823a022f86de99c08b47f2962;hp=faee90cddb7c412dfac1a84022f5f91881c8c201;hb=c0f4a4d5ce63338390dfd851c4b403769266d0d7;hpb=d5a0b74a3ddd8ad47fb594e890dfd0f454627655 diff --git a/scanlib.pm b/scanlib.pm index faee90c..60e4cf4 100644 --- a/scanlib.pm +++ b/scanlib.pm @@ -1,65 +1,36 @@ #! /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 LWP::UserAgent; +use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522); +use Debbugs::Packages; +use Debbugs::Versions; +use Debbugs::Status; +use Fcntl qw(O_RDONLY); +use strict; +use warnings; require bugcfg; +package scanlib; -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) - - local($index); # Bug-number for current comment - local($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 sub readmaintainers() { - local ($pkg); # Name of package - local ($mnt); # Maintainer name & email + my $pkg; # Name of package + my $mnt; # Maintainer name & email - open(M, $maintainerlist) or die "open $maintainerlist: $!\n"; + open(M, $bugcfg::maintainerlist) or die "open $bugcfg::maintainerlist: $!\n"; while () { chomp; m/^(\S+)\s+(\S.*\S)\s*$/ or die "Maintainers: $_ ?"; @@ -76,15 +47,15 @@ sub readmaintainers() { sub readsources() { - local($root); # Root of archive we are scanning - local($archive); # Name of archive we are scanning - local($sect); # Name of current section + my $root; # Root of archive we are scanning + my $archive; # Name of archive we are scanning + my $sect; # Name of current section $root=shift; $archive=shift; - for $sect ( @sections) { + for $sect (@bugcfg::sections) { open(P, "zcat $root/$sect/source/Sources.gz|") - or die open "open: $sect / $arch sourcelist: $!\n"; + or die open "open: $sect sourcelist: $!\n"; while (

) { chomp; next unless m/^Package:\s/; @@ -95,16 +66,10 @@ sub readsources() { } } -sub readpackages() { - local($root); # Root of archive we are scanning - local($archive); # Name of archive we are scanning - local($sect); # Name of current section - local($arch); # Name of current architecture - - $root=shift; - $archive=shift; - for $arch ( @architectures ) { - for $sect ( @sections) { +sub readpackages { + my ($root,$archive) = @_; + for my $arch ( @bugcfg::architectures ) { + for my $sect ( @bugcfg::sections) { open(P, "zcat $root/$sect/binary-$arch/Packages.gz|") or die "open: $root/$sect/binary-$arch/Packages.gz: $!\n"; while (

) { @@ -112,15 +77,28 @@ sub readpackages() { next unless m/^Package:\s/; # We're only interested in the packagenames s/^Package:\s*//; # Strip the fieldname $section{$_} = "$archive/$sect"; + print "$root/$sect/binary-$arch/Packages.gz\n" if ($_ eq 'xtla'); } close(P); } } + # handle the source packages + for my $sect (@bugcfg::sections) { + my $fh; + open($fh,'-|','zcat',"$root/$sect/source/Sources.gz") or + die "Unable to open zcat $root/$sect/source/Sources.gz for reading: $!"; + while (<$fh>) { + chomp; + next unless m/^Package:\s/; # We're only interested in the packagenames + s/^Package:\s*//; # Strip the fieldname + $section{$_} = "$archive/$sect"; + } + } } sub readdebbugssources() { - local($file); - local($archive); + my $file; + my $archive; $file=shift; $archive=shift; @@ -137,7 +115,7 @@ sub readdebbugssources() { } sub readpseudopackages() { - open(P, $pseudolist) or die("open $pseudolist: $!\n"); + open(P, $bugcfg::pseudolist) or die("open $bugcfg::pseudolist: $!\n"); while (

) { chomp; s/\s.*//; @@ -148,177 +126,170 @@ sub readpseudopackages() { sub scanspool() { - local(@dirs); - local($dir); + my @dirs; + my $dir; - chdir($spooldir) or die "chdir $spooldir: $!\n"; + chdir($bugcfg::spooldir) or die "chdir $bugcfg::spooldir: $!\n"; - opendir(DIR, $spooldir) or die "opendir $spooldir: $!\n"; + opendir(DIR, $bugcfg::spooldir) or die "opendir $bugcfg::spooldir: $!\n"; @dirs=grep(m/^\d+$/,readdir(DIR)); closedir(DIR); for $dir (@dirs) { - scanspooldir("$spooldir/$dir"); + scanspooldir("$bugcfg::spooldir/$dir"); } } -sub scanspooldir() { - local($dir) = @_; - local($f); # While we're currently processing - local(@list); # List of files to process - local($s_originator, $s_date, $s_subject, $s_msgid, $s_package, $s_keywords); - local($s_done, $s_forwarded, $s_mergedwith, $s_severity); - local($skip); # Flow control - local($walk); # index variable - local($taginfo); # Tag info +sub scanspooldir { + my ($dir) = @_; + my $f; # While we're currently processing + my @list; # List of files to process + my $skip; # Flow control + my $walk; # index variable + my $taginfo; # Tag info + + my @archs_with_source = ( @bugcfg::architectures, 'source' ); chdir($dir) or die "chdir $dir: $!\n"; opendir(DIR, $dir) or die "opendir $dir: $!\n"; - @list = grep { s/\.status$// } - grep { m/^\d+\.status$/ } + @list = grep { s/\.summary$// } + grep { m/^\d+\.summary$/ } readdir(DIR); closedir(DIR); for $f (@list) { - next if $exclude{$f}; # Check the list of bugs to skip - next if (!open(S,"$f.status")); # Check bugs without a status (?) - - chomp($s_originator = ); - chomp($s_date = ); - chomp($s_subject = ); - chomp($s_msgid = ); - chomp($s_package = ); - chomp($s_tags = ); - chomp($s_done = ); - chomp($s_forwarded = ); - chomp($s_mergedwith = ); - chomp($s_severity = ); - close(S); - - next if length($s_done) and not $premature{$f}; - $premature{$f}++ if length($s_done); - - $s_severity =~ y/A-Z/a-z/; - $s_tags =~ y/A-Z/a-z/; - + 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 (@priorities) { - $skip=0 if $walk eq $s_severity; + for $walk (@bugcfg::priorities) { + $skip=0 if $walk eq $bug->{'severity'}; } - for $tag (split(' ', $s_tags)) { - for $s (@skiptags) { + my @tags = split(' ', $bug->{'keywords'}); + for my $tag (@tags) { + for my $s (@bugcfg::skiptags) { $skip=1 if $tag eq $s; } } next if $skip==1; - - $relinfo = ""; - $relinfo .= ($s_tags =~ /\bwoody\b/ ? "O" : ""); - $relinfo .= ($s_tags =~ /\bsarge(|\s.*)%/ ? "S" : ""); - $relinfo .= ($s_tags =~ /\betch(|\s.*)$/ ? "T" : ""); - # etch-ignore matches \betch\b :( - $relinfo .= ($s_tags =~ /\bsid\b/ ? "U" : ""); - $relinfo .= ($s_tags =~ /\bexperimental\b/ ? "E" : ""); - - $taginfo = "["; - $taginfo .= ($s_tags =~ /\bpending\b/ ? "P" : " "); - $taginfo .= ($s_tags =~ /\bpatch\b/ ? "+" : " "); - $taginfo .= ($s_tags =~ /\bhelp\b/ ? "H" : " "); - $taginfo .= ($s_tags =~ /\bmoreinfo\b/ ? "M" : " "); - $taginfo .= ($s_tags =~ /\bunreproducible\b/ ? "R" : " "); - $taginfo .= ($s_tags =~ /\bsecurity\b/ ? "S" : " "); - $taginfo .= ($s_tags =~ /\bupstream\b/ ? "U" : " "); - $taginfo .= ($s_tags =~ /\betch-ignore\b/ ? "I" : " "); - $taginfo .= "]"; - - if ($s_mergedwith) { # Only show the first package if things are merged - my @merged = split(' ', $s_mergedwith); - next if ($merged[0] < $f); + + my %disttags = (); + $disttags{'oldstable'} = grep(/^lenny$/, @tags); + $disttags{'stable'} = grep(/^squeeze$/, @tags); + $disttags{'testing'} = grep(/^wheezy$/, @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; } - - for $package (split /[,\s]+/, $s_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 + + 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; + + # 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 => \@archs_with_source + ); + + # 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; + } - $packagelist{$_} .= " $f"; + for my $keyword qw(pending patch help moreinfo unreproducible security upstream etch-ignore lenny-ignore squeeze-ignore wheezy-ignore) { + $bi->{$keyword} = grep(/^$keyword$/, @tags); } - if ($relinfo eq "") { # or $relinfo eq "U" # confuses e.g. #210306 - $relinfo = ""; - } else { - $relinfo = " [$relinfo]"; + if (length($bug->{'mergedwith'})) { + my @merged = split(' ', $bug->{'mergedwith'}); + next if ($merged[0] < $f); } - $bugs{$f} = "$f $taginfo$relinfo $s_subject"; + for my $package (split /[,\s]+/, $bug->{'package'}) { + $_= $package; y/A-Z/a-z/; $_= $` if m/[^-+._:a-z0-9]/; + push @{$packagelist{$_}}, $f; + } + + my $taginfo = get_taginfo($bi); + my $relinfo = get_relinfo($bi); + + $bugs{$f} = $bi; } } -sub readstatus() { - local ($bug); # Number of current bug - local ($subject); # Subject for current bug - local ($pkg); # Name of current package - local ($file); # Name of statusfile - local ($sect); # Section of current package - local ($mnt); # Maintainer of current package +sub readstatus { + my $filename = shift; + open STATUS, "<", $filename + or die "$filename: $!"; - $file=shift; - open(P, $file) or die "open $file: $!"; - while (

) { - chomp; - if (m/^[0-9]+ \[/) { - ($bug,$subject)=split(/ /, $_, 2); - $bugs{$bug}=$subject; - $packagelist{$pkg} .= "$bug "; - } else { - ($pkg,$sect, $mnt)=split(/ /, $_, 3); - $section{$pkg}=$sect; - $maintainer{$pkg}=$mnt; - } - } - close P; -} + 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; + } + if ($type eq 'bug') { + my $bug = {}; + while (1) { + my $line = ; + last if ($line !~ /^(.*?)=(.*)$/); -sub readNMUstatus() { - local ($bug); # Number of current bug - local ($source); # Source upload which closes this bug. - local ($version); # Version where this bug was closed. - local ($flag); # Whether this paragraph has been processed. - local ($field, $value); + $bug->{$1} = $2; + } + $bugs{$bug->{'number'}} = $bug; - 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); } @@ -339,22 +310,63 @@ sub htmlsanit { } sub wwwnumber() { - local ($number) = shift; # Number of bug to html-ize -# local ($section); # Section for the bug + my $number = shift; # Number of bug to html-ize "' . htmlsanit($number) . ''; -# ($section=$number) =~ s/([0-9]{2}).*/$1/; -# "$number"; } sub wwwname() { - local ($name) = shift; # Name of package + my $name = shift; # Name of package "' . htmlsanit($name) . ''; -# "$name"; } -1; +sub check_worry { + my ($bi) = @_; + + return ($bi->{'testing'} && !$bi->{'wheezy-ignore'}); +} + +sub check_worry_stable { + my ($bi) = @_; + + return ($bi->{'stable'} && !$bi->{'squeeze-ignore'}); +} +sub check_worry_unstable { + my ($bi) = @_; + + return ($bi->{'unstable'}); +} + +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->{'wheezy-ignore'} || $bi->{'squeeze-ignore'}) ? "I" : " "; + + 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 $relinfo; +} + + +1;