X-Git-Url: https://git.donarmstrong.com/?p=bugscan.git;a=blobdiff_plain;f=scanlib.pm;h=4c6b09bf03a8fab543e246e117c6e3889f4aae2a;hp=c52291eb18cfa989b6bc9cbc0cae619f06a73dc7;hb=882c3a5e8e8d32eb965a7d1f805f8ea31668b91c;hpb=5f6c1f40e3036cd62c16e425090d0608d01a78d1 diff --git a/scanlib.pm b/scanlib.pm index c52291e..4c6b09b 100644 --- a/scanlib.pm +++ b/scanlib.pm @@ -1,13 +1,11 @@ #! /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: -# %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 @@ -24,7 +22,7 @@ use warnings; require bugcfg; package scanlib; -our (%premature,%exclude,%maintainer,%section,%packagelist,%debbugssection,%bugs); +our (%maintainer,%section,%packagelist,%debbugssection,%bugs); # Read the list of maintainer @@ -68,16 +66,10 @@ sub readsources() { } } -sub readpackages() { - 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 ( @bugcfg::architectures ) { - for $sect ( @bugcfg::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 (

) { @@ -85,10 +77,23 @@ 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() { @@ -136,13 +141,15 @@ sub scanspool() { } -sub scanspooldir() { +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"; @@ -153,11 +160,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'}; @@ -171,25 +182,24 @@ sub scanspooldir() { } next if $skip==1; - my %disttags = (); - $disttags{'oldstable'} = grep(/^woody$/, @tags); - $disttags{'stable'} = grep(/^sarge$/, @tags); - $disttags{'testing'} = grep(/^etch$/, @tags); - $disttags{'unstable'} = grep(/^sid$/, @tags); + my %disttags = (); + for (qw(oldstable stable testing unstable)) { + $disttags{$_} = grep(/^$bug_cfg::debian_releases->{$_}$/, @tags); + } $disttags{'experimental'} = grep(/^experimental$/, @tags); - # default according to dondelelcaro 2006-11-11 + # 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; } - my $bi = {}; 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) { + for my $dist (qw(oldstable stable testing unstable experimental)) { $bi->{$dist} = $disttags{$dist}; } next if (length($bug->{'done'})); @@ -197,7 +207,7 @@ sub scanspooldir() { 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) { + for my $dist (qw(oldstable stable testing unstable experimental)) { local $SIG{__WARN__} = sub {}; $bi->{$dist} = 0; @@ -207,7 +217,7 @@ sub scanspooldir() { bug => $f, status => $bug, dist => $dist, - arch => \@bugcfg::architectures + arch => \@archs_with_source ); # ignore bugs that are absent/fixed in this distribution, include everything @@ -220,12 +230,12 @@ sub scanspooldir() { } } - next if !$affects_any and not $premature{$f}; - $premature{$f}++ if !$affects_any; + next if !$affects_any; } - for my $keyword qw(pending patch help moreinfo unreproducible security upstream etch-ignore) { - $bi->{$keyword} = ($bug->{'keywords'} =~ /\b$keyword\b/) ? 1 : 0; + for my $keyword (qw(pending patch help moreinfo unreproducible security upstream), + map {$_.$bug_cfg::debian_releases->{testing}.'-ignore'} keys %{$bug_cfg::debian_releases}) { + $bi->{$keyword} = grep(/^$keyword$/, @tags); } if (length($bug->{'mergedwith'})) { @@ -234,42 +244,52 @@ sub scanspooldir() { } for my $package (split /[,\s]+/, $bug->{'package'}) { - $_= $package; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9]/; + $_= $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} = "$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 +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; - push @{$packagelist{$pkg}}, $bug; - } else { - ($pkg,$sect, $mnt)=split(/ /, $_, 3); - next if (!defined($pkg)); - $section{$pkg}=$sect; - $maintainer{$pkg}=$mnt; + 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 !~ /^(.*?)=(.*)$/); + + $bug->{$1} = $2; + } + $bugs{$bug->{'number'}} = $bug; + + 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'); } - close P; + close(STATUS); } @@ -304,22 +324,21 @@ sub wwwname() { } sub check_worry { - my ($status) = @_; + my ($bi) = @_; - if ($status =~ m/^\[[^]]*I/ or - $status !~ m/ \[[^]]*T/) { - return 0; - } - return 1; + return ($bi->{'testing'} && !$bi->{$bug_cfg::debian_releases->{testing}.'-ignore'}); } sub check_worry_stable { - my ($status) = @_; + my ($bi) = @_; - if ($status !~ m/ \[[^]]*S/) { - return 0; - } - return 1; + return ($bi->{'stable'} && !$bi->{$bug_cfg::debian_releases->{stable}.'-ignore'}); +} + +sub check_worry_unstable { + my ($bi) = @_; + + return ($bi->{'unstable'}); } sub get_taginfo { @@ -333,7 +352,7 @@ sub get_taginfo { $taginfo .= $bi->{'unreproducible'} ? "R" : " "; $taginfo .= $bi->{'security'} ? "S" : " "; $taginfo .= $bi->{'upstream'} ? "U" : " "; - $taginfo .= $bi->{'etch-ignore'} ? "I" : " "; + $taginfo .= ($bi->{$bug_cfg::debian_releases->{stable}.'-ignore'} || $bi->{$bug_cfg::debian_releases->{testing}.'-ignore'}) ? "I" : " "; return $taginfo; } @@ -342,7 +361,7 @@ sub get_relinfo { my $bi = shift; my $relinfo = ""; - for my $dist qw(oldstable stable testing unstable experimental) { + for my $dist (qw(oldstable stable testing unstable experimental)) { $relinfo .= uc(substr($dist, 0, 1)) if $bi->{$dist}; }