X-Git-Url: https://git.donarmstrong.com/?p=bugscan.git;a=blobdiff_plain;f=scanlib.pm;h=82ad6cf0c76bb24c9c337611e3ace97a67b7537b;hp=faee90cddb7c412dfac1a84022f5f91881c8c201;hb=b466d60ef751700a50478b94761418d5a5ef55c1;hpb=d5a0b74a3ddd8ad47fb594e890dfd0f454627655 diff --git a/scanlib.pm b/scanlib.pm index faee90c..82ad6cf 100644 --- a/scanlib.pm +++ b/scanlib.pm @@ -14,8 +14,19 @@ # %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; + +our (%comments,%premature,%exclude,%maintainer,%section,%packagelist,%NMU,%debbugssection,%bugs); sub readcomments() { # Read bug commentary @@ -24,8 +35,8 @@ sub readcomments() { # 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 + my $index; # Bug-number for current comment + my $file; # Name of comments-file %comments = (); # Initialize our data %premature = (); @@ -56,10 +67,10 @@ sub readcomments() { # 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 +87,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/; @@ -96,15 +107,15 @@ 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 + my $root; # Root of archive we are scanning + my $archive; # Name of archive we are scanning + my $sect; # Name of current section + my $arch; # Name of current architecture $root=shift; $archive=shift; - for $arch ( @architectures ) { - for $sect ( @sections) { + for $arch ( @bugcfg::architectures ) { + for $sect ( @bugcfg::sections) { open(P, "zcat $root/$sect/binary-$arch/Packages.gz|") or die "open: $root/$sect/binary-$arch/Packages.gz: $!\n"; while (

) { @@ -119,8 +130,8 @@ sub readpackages() { } sub readdebbugssources() { - local($file); - local($archive); + my $file; + my $archive; $file=shift; $archive=shift; @@ -137,7 +148,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,98 +159,103 @@ 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 + 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 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)); + $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; + + 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; + } - $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" : ""); + # 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 .= ($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 .= ($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 .= "]"; - if ($s_mergedwith) { # Only show the first package if things are merged - my @merged = split(' ', $s_mergedwith); + if (length($bug->{'mergedwith'})) { + my @merged = split(' ', $bug->{'mergedwith'}); next if ($merged[0] < $f); } - for $package (split /[,\s]+/, $s_package) { + 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{$_}) { @@ -249,7 +265,7 @@ sub scanspooldir() { } } - $packagelist{$_} .= " $f"; + push @{$packagelist{$_}}, $f; } if ($relinfo eq "") { # or $relinfo eq "U" # confuses e.g. #210306 @@ -258,18 +274,18 @@ sub scanspooldir() { $relinfo = " [$relinfo]"; } - $bugs{$f} = "$f $taginfo$relinfo $s_subject"; + $bugs{$f} = "$f $taginfo$relinfo " . $bug->{'subject'}; } } 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 + 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: $!"; @@ -278,9 +294,10 @@ sub readstatus() { if (m/^[0-9]+ \[/) { ($bug,$subject)=split(/ /, $_, 2); $bugs{$bug}=$subject; - $packagelist{$pkg} .= "$bug "; + push @{$packagelist{$pkg}}, $bug; } else { ($pkg,$sect, $mnt)=split(/ /, $_, 3); + next if (!defined($pkg)); $section{$pkg}=$sect; $maintainer{$pkg}=$mnt; } @@ -290,11 +307,11 @@ sub readstatus() { 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); + 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; @@ -339,8 +356,8 @@ 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 +# my $section); # Section for the bug "' . htmlsanit($number) . ''; @@ -349,12 +366,46 @@ sub wwwnumber() { } sub wwwname() { - local ($name) = shift; # Name of package + my $name = shift; # Name of package "' . htmlsanit($name) . ''; # "$name"; } -1; +my $_version_cache = {}; +sub get_status() { + my ($bugnr, $bug, $dist) = @_; + + my @versions = Debbugs::Status::getversions($bug->{'package'}, $dist, undef); + my @sourceversions = Debbugs::Status::makesourceversions($bug->{'package'}, undef, @versions); + 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; + } + } + + return 'pending'; +} + +sub check_worry { + my ($status) = @_; + + if ($status =~ m/^\[[^]]*I/ or + $status =~ m/ \[[^]]*X/ or + ($status =~ m/ \[[^]]*[OSUE]/ and $status !~ m/ \[[^]]*T/)) { + return 0; + } + return 1; +}