Make dohtml output a separate page for only testing-related bugs.
[bugscan.git] / scanlib.pm
1 #! /usr/bin/perl
2 # vim: ts=4 sw=4 nowrap
3 #
4 # General functions for scanning the BTS-database.
5 # Based on bugscan, written by Richard Braakman <dark@debian.org>,
6 # which was based on an unknown other script.
7 #
8 # Global variables:
9 #   %comments       - map from bugnumber to bug description
10 #   %premature      - list of prematurely closed bugreports
11 #   %exclude        - list of bugreports to exclude from the report
12 #   %maintainer     - map from packagename to maintainer
13 #   %section        - map from packagename to section in the FTP-site
14 #   %packagelist    - map from packagename to bugreports
15 #   %NMU            - map with NMU information
16
17 use lib qw(/org/bugs.debian.org/perl/);
18 use LWP::UserAgent;
19 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
20 use Debbugs::Packages;
21 use Debbugs::Versions;
22 use Fcntl qw(O_RDONLY);
23 require bugcfg;
24
25 sub readcomments() {
26 # Read bug commentary 
27 # It is in paragraph format, with the first line of each paragraph being
28 # the bug number or package name to which the comment applies.
29 # Prefix a bug number with a * to force it to be listed even if it's closed.
30 # (This deals with prematurely closed bugs)
31
32         local($index);                                  # Bug-number for current comment
33         local($file);                                   # Name of comments-file
34
35         %comments = ();                                 # Initialize our data
36         %premature = ();
37         %exclude = ();
38         $file=shift;
39         open(C, $file) or die "open $file: $!\n";
40         while (<C>) {
41                 chomp;
42                 if (m/^\s*$/) {                         # Check for paragraph-breaks
43                         undef $index;
44                 } elsif (defined $index) {
45                         $comments{$index} .= $_ . "\n";
46                 } else {
47                         if (s/^\*//) {                  # Test & remove initial *
48                                 $premature{$_} = 1;
49                         }
50                         if (s/\s+EXCLUDE\s*//) {        # Test & remove EXCLUDE
51                                 $exclude{$_} = 1;
52                                 next;
53                         }
54                         $index = $_;
55                         $comments{$index} = ''; # New comment, initialize data
56                 }
57         }
58         close(C);
59 }
60
61
62 # Read the list of maintainer 
63 sub readmaintainers() {
64         local ($pkg);                                   # Name of package
65         local ($mnt);                                   # Maintainer name & email
66
67         open(M, $maintainerlist) or die "open $maintainerlist: $!\n";
68         while (<M>) {
69                 chomp;
70                 m/^(\S+)\s+(\S.*\S)\s*$/ or die "Maintainers: $_ ?";
71                 ($pkg, $mnt) = ($1, $2);
72                 $pkg =~ y/A-Z/a-z/;                     # Normalize package-name. why???
73                 $_=$mnt;
74                 if (not m/</) {
75                         $mnt="$2 <$1>" if ( m/(\S+)\s+\(([^)]+)\)/ );
76                 }
77                 $maintainer{$pkg}= $mnt;
78         }
79         close(M);
80 }
81
82
83 sub readsources() {
84         local($root);                                   # Root of archive we are scanning
85         local($archive);                                # Name of archive we are scanning
86         local($sect);                                   # Name of current section
87
88         $root=shift;
89         $archive=shift;
90         for $sect ( @sections) {
91                 open(P, "zcat $root/$sect/source/Sources.gz|")
92                         or die open "open: $sect / $arch sourcelist: $!\n";
93                 while (<P>) {
94                         chomp;
95                         next unless m/^Package:\s/;
96                         s/^Package:\s*//;                       # Strip the fieldname
97                         $section{$_} = "$archive/$sect";
98                 }
99                 close (P);
100         }
101 }
102
103 sub readpackages() {
104         local($root);                                   # Root of archive we are scanning
105         local($archive);                                # Name of archive we are scanning
106         local($sect);                                   # Name of current section
107         local($arch);                                   # Name of current architecture
108
109         $root=shift;
110         $archive=shift;
111         for $arch ( @architectures ) {
112                 for $sect ( @sections) {
113                         open(P, "zcat $root/$sect/binary-$arch/Packages.gz|")
114                                 or die "open: $root/$sect/binary-$arch/Packages.gz: $!\n";
115                         while (<P>) {
116                                 chomp;
117                                 next unless m/^Package:\s/;     # We're only interested in the packagenames
118                                 s/^Package:\s*//;                       # Strip the fieldname
119                                 $section{$_} = "$archive/$sect";
120                         }
121                         close(P);
122                 }
123         }
124 }
125
126 sub readdebbugssources() {
127         local($file);
128         local($archive);
129
130         $file=shift;
131         $archive=shift;
132         open(P, $file)
133                 or die "open: $file: $!\n";
134         while (<P>) {
135                 chomp;
136                 my ($host, $bin, $sect, $ver, $src) = split /\s+/;
137                 my $sectname = ($sect =~ /^\Q$archive/) ? $sect : "$archive/$sect";
138                 $debbugssection{$bin} = $sectname;
139                 $debbugssection{$src} = $sectname;
140         }
141         close(P);
142 }
143
144 sub readpseudopackages() {
145         open(P, $pseudolist) or die("open $pseudolist: $!\n");
146         while (<P>) {
147                 chomp;
148                 s/\s.*//;
149                 $section{$_} = "pseudo";
150         }
151         close(P);
152 }
153
154
155 sub scanspool() {
156         local(@dirs);
157         local($dir);
158
159         chdir($spooldir) or die "chdir $spooldir: $!\n";
160
161         opendir(DIR, $spooldir) or die "opendir $spooldir: $!\n";
162         @dirs=grep(m/^\d+$/,readdir(DIR));
163         closedir(DIR);
164
165         for $dir (@dirs) {
166                 scanspooldir("$spooldir/$dir");
167         }
168
169 }
170
171 sub scanspooldir() {
172         local($dir)             = @_;
173         local($f);                      # While we're currently processing
174         local(@list);           # List of files to process
175         local($skip);           # Flow control
176         local($walk);           # index variable
177         local($taginfo);        # Tag info
178
179         chdir($dir) or die "chdir $dir: $!\n";
180
181         opendir(DIR, $dir) or die "opendir $dir: $!\n";
182         @list = grep { s/\.summary$// }
183                         grep { m/^\d+\.summary$/ } 
184                         readdir(DIR);
185         closedir(DIR);
186
187         for $f (@list) {
188                 next if $exclude{$f};                   # Check the list of bugs to skip
189         
190                 my $bug = readbug("$f.summary");
191                 next if (!defined($bug));
192                 
193                 $skip=1;
194                 for $walk (@priorities) {
195                         $skip=0 if $walk eq $bug->{'severity'};
196                 }
197
198                 my @tags = split(' ', $bug->{'keywords'});
199                 for $tag (@tags) {
200                         for $s (@skiptags) {
201                                 $skip=1 if $tag eq $s;
202                         }
203                 }
204                 next if $skip==1;
205                 
206                 my $oldstable_tag    = grep(/^woody$/, @tags);
207                 my $stable_tag       = grep(/^sarge$/, @tags);
208                 my $testing_tag      = grep(/^etch$/, @tags);
209                 my $unstable_tag     = grep(/^sid$/, @tags);
210                 my $experimental_tag = grep(/^experimental$/, @tags);
211
212                 # default according to dondelelcaro 2006-11-11
213                 if (!$oldstable_tag && !$stable_tag && !$testing_tag && !$unstable_tag && !$experimental_tag) {
214                         $testing_tag = 1;
215                         $unstable_tag = 1;
216                         $experimental_tag = 1;
217                 }
218
219                 # only bother to check the versioning status for the distributions indicated by the tags 
220                 $status_oldstable    = getbugstatus($bug, undef, 'oldstable')    if ($oldstable_tag);
221                 $status_stable       = getbugstatus($bug, undef, 'stable')       if ($stable_tag);
222                 $status_testing      = getbugstatus($bug, undef, 'testing')      if ($testing_tag);
223                 $status_unstable     = getbugstatus($bug, undef, 'unstable')     if ($unstable_tag);
224                 $status_experimental = getbugstatus($bug, undef, 'experimental') if ($experimental_tag);
225
226                 $relinfo = "";
227                 $relinfo .= (($oldstable_tag    && $status_oldstable->{'pending'}    eq 'pending') ? "O" : "");
228                 $relinfo .= (($stable_tag       && $status_stable->{'pending'}       eq 'pending') ? "S" : "");
229                 $relinfo .= (($testing_tag      && $status_testing->{'pending'}      eq 'pending') ? "T" : "");
230                 $relinfo .= (($unstable_tag     && $status_unstable->{'pending'}     eq 'pending') ? "U" : "");
231                 $relinfo .= (($experimental_tag && $status_experimental->{'pending'} eq 'pending') ? "E" : "");
232                 
233                 next if $relinfo eq '' and not $premature{$f};
234                 $premature{$f}++ if $relinfo eq '';
235
236                 $taginfo = "[";
237                 $taginfo .= ($bug->{'keywords'} =~ /\bpending\b/        ? "P" : " ");
238                 $taginfo .= ($bug->{'keywords'} =~ /\bpatch\b/          ? "+" : " ");
239                 $taginfo .= ($bug->{'keywords'} =~ /\bhelp\b/           ? "H" : " ");
240                 $taginfo .= ($bug->{'keywords'} =~ /\bmoreinfo\b/       ? "M" : " ");
241                 $taginfo .= ($bug->{'keywords'} =~ /\bunreproducible\b/ ? "R" : " ");
242                 $taginfo .= ($bug->{'keywords'} =~ /\bsecurity\b/       ? "S" : " ");
243                 $taginfo .= ($bug->{'keywords'} =~ /\bupstream\b/       ? "U" : " ");
244                 $taginfo .= ($bug->{'keywords'} =~ /\betch-ignore\b/    ? "I" : " ");
245                 $taginfo .= "]";
246
247                 if (length($bug->{'mergedwith'})) {
248                         my @merged = split(' ', $bug->{'mergedwith'});
249                         next if ($merged[0] < $f);
250                 }
251
252                 for $package (split /[,\s]+/, $bug->{'package'}) {
253                         $_= $package; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9]/;
254                         if (not defined $section{$_}) {
255                                 if (defined $debbugssection{$_}) {
256                                         $relinfo .= "X";
257                                 } else {
258                                         next;   # Skip unavailable packages
259                                 }
260                         }
261
262                         $packagelist{$_} .= " $f";
263                 }
264
265                 if ($relinfo eq "") { # or $relinfo eq "U" # confuses e.g. #210306
266                         $relinfo = "";
267                 } else {
268                         $relinfo = " [$relinfo]";
269                 }
270
271                 $bugs{$f} = "$f $taginfo$relinfo " . $bug->{'subject'};
272         }
273 }
274
275
276 sub readstatus() {
277         local ($bug);           # Number of current bug
278         local ($subject);       # Subject for current bug
279         local ($pkg);           # Name of current package
280         local ($file);          # Name of statusfile
281         local ($sect);          # Section of current package
282         local ($mnt);           # Maintainer of current package
283
284         $file=shift;
285         open(P, $file) or die "open $file: $!";
286         while (<P>) {
287                 chomp;
288                 if (m/^[0-9]+ \[/) {
289                         ($bug,$subject)=split(/ /, $_, 2);
290                         $bugs{$bug}=$subject;
291                         $packagelist{$pkg} .= "$bug ";
292                 } else {
293                         ($pkg,$sect, $mnt)=split(/ /, $_, 3);
294                         $section{$pkg}=$sect;
295                         $maintainer{$pkg}=$mnt;
296                 }
297         }
298         close P;
299 }
300
301
302 sub readNMUstatus() {
303         local ($bug);       # Number of current bug
304         local ($source);    # Source upload which closes this bug.
305         local ($version);   # Version where this bug was closed.
306         local ($flag);      # Whether this paragraph has been processed.
307         local ($field, $value);
308
309         for (split /\n/, LWP::UserAgent->new->request(HTTP::Request->new(GET => shift))->content) {
310                 chomp;
311                 if (m/^$/) {
312                         $NMU{$bug} = 1;
313                         $NMU{$bug, "source"} = $source;
314                         $NMU{$bug, "version"} = $version;
315 #                       $comments{$bug} .= "[FIXED] Fixed package $source is in Incoming\n";
316                         $flag = 0;
317                 } else {
318                         ($field, $value) = split(/: /, $_, 2);
319                         $bug = $value if($field =~ /bug/i);
320                         $source = $value if($field =~ /source/i);
321                         $version = $value if($field =~ /version/i);
322                         $flag = 1;
323                 }
324         }
325         if ($flag) {
326                 $NMU{$bug} = 1;
327                 $NMU{$bug, "source"} = $source;
328                 $NMU{$bug, "version"} = $version;
329 #               $comments{$bug} .= "[FIXED] Fixed package $source in in Incoming\n";
330         }
331         close P;
332 }
333
334
335 sub urlsanit {
336         my $url = shift;
337         $url =~ s/%/%25/g;
338         $url =~ s/\+/%2b/g;
339         my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
340         $url =~ s/([<>&"])/\&$saniarray{$1};/g;
341         return $url;
342 }
343
344 sub htmlsanit {
345     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
346     my $in = shift || "";
347     $in =~ s/([<>&"])/\&$saniarray{$1};/g;
348     return $in;
349 }
350
351 sub wwwnumber() {
352         local ($number) = shift;                # Number of bug to html-ize
353 #       local ($section);                               # Section for the bug
354
355         "<A HREF=\"http://bugs.debian.org/cgi-bin/bugreport.cgi?archive=no&amp;bug=" .
356                 urlsanit($number) . '">' . htmlsanit($number) . '</A>';
357 #       ($section=$number) =~ s/([0-9]{2}).*/$1/;
358 #       "<A HREF=\"${btsURL}/db/$section/$number.html\">$number</A>";
359 }
360
361 sub wwwname() {
362         local ($name) = shift;                  # Name of package
363
364         "<A HREF=\"http://bugs.debian.org/cgi-bin/pkgreport.cgi?archive=no&amp;pkg=" .
365                 urlsanit($name) . '">' . htmlsanit($name) . '</A>';
366 #       "<A HREF=\"${btsURL}/db/pa/l$name.html\">$name</A>";
367 }
368
369 # === everything from here is adapted from debbugs, and should probably be merged
370 # === back at some point
371
372 my %_binarytosource;
373 my %_binarytosourcecache = ();
374 sub binarytosource {
375     my ($binname, $binver, $binarch) = @_;
376
377     # TODO: This gets hit a lot, especially from buggyversion() - probably
378     # need an extra cache for speed here.
379
380     if (tied %_binarytosource or
381             tie %_binarytosource, 'MLDBM',
382                 $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
383                 if (!exists($_binarytosourcecache{$binname})) {
384                         $_binarytosourcecache{$binname} = \%{ $_binarytosource{$binname} };
385                 }
386                 
387                 if (defined $_binarytosourcecache{$binname} and
388                         exists $_binarytosourcecache{$binname}{$binver}) {
389                         if (defined $binarch) {
390                                 my $src = $_binarytosourcecache{$binname}{$binver}{$binarch};
391                                 return () unless defined $src; # not on this arch
392                                 # Copy the data to avoid tiedness problems.
393                                 return [@$src];
394                         } else {
395                                 # Get (srcname, srcver) pairs for all architectures and
396                                 # remove any duplicates. This involves some slightly tricky
397                                 # multidimensional hashing; sorry. Fortunately there'll
398                                 # usually only be one pair returned.
399                                 my %uniq;
400                                 for my $ar (keys %{$_binarytosourcecache{$binname}{$binver}}) {
401                                         my $src = $_binarytosourcecache{$binname}{$binver}{$ar};
402                                         next unless defined $src;
403                                         $uniq{$src->[0]}{$src->[1]} = 1;
404                                 }
405                                 my @uniq;
406                                 for my $sn (sort keys %uniq) {
407                                         push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
408                                 }
409                                 return @uniq;
410                         }
411                 }
412     }
413
414     # No $gBinarySourceMap, or it didn't have an entry for this name and
415     # version.
416     return ();
417 }
418
419 my %_versionobj;
420 sub buggyversion {
421     my ($bug, $ver, $status) = @_;
422     return '' unless defined $versionpkgdir;
423     my $src = getpkgsrc()->{$status->{package}};
424     $src = $status->{package} unless defined $src;
425
426     my $tree;
427     if (exists $_versionobj{$src}) {
428         $tree = $_versionobj{$src};
429     } else {
430         $tree = Debbugs::Versions->new(\&DpkgVer::vercmp);
431         my $srchash = substr $src, 0, 1;
432         if (open VERFILE, "< $versionpkgdir/$srchash/$src") {
433             $tree->load(\*VERFILE);
434             close VERFILE;
435         }
436         $_versionobj{$src} = $tree;
437     }
438
439     my @found = makesourceversions($status->{package}, undef,
440                                    @{$status->{found_versions}});
441     my @fixed = makesourceversions($status->{package}, undef,
442                                    @{$status->{fixed_versions}});
443
444     return $tree->buggy($ver, \@found, \@fixed);
445 }
446
447 sub getbugstatus {
448     my ($bug,$common_version,$common_dist) = @_;
449         my %status = %$bug;
450
451     my @versions;
452     if (defined $common_version) {
453         @versions = ($common_version);
454     } elsif (defined $common_dist) {
455         @versions = getversions($status{package}, $common_dist, $common_arch);
456     }
457     
458         if (not @versions) {
459                 $status{"pending"} = 'absent';
460                 return \%status;
461         }
462
463     # TODO: This should probably be handled further out for efficiency and
464     # for more ease of distinguishing between pkg= and src= queries.
465     my @sourceversions = makesourceversions($status{package}, $common_arch,
466                                             @versions);
467
468         $status{"pending"} = 'pending';
469
470     if (@sourceversions) {
471         # Resolve bugginess states (we might be looking at multiple
472         # architectures, say). Found wins, then fixed, then absent.
473         my $maxbuggy = 'absent';
474         for my $version (@sourceversions) {
475             my $buggy = buggyversion($bugnum, $version, \%status);
476             if ($buggy eq 'found') {
477                 $maxbuggy = 'found';
478                 last;
479             } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
480                 $maxbuggy = 'fixed';
481             }
482         }
483         if ($maxbuggy eq 'absent') {
484             $status{"pending"} = 'absent';
485         } elsif ($maxbuggy eq 'fixed') {
486             $status{"pending"} = 'done';
487         }
488     }
489     
490     if (length($status{done}) and
491             (not @sourceversions or not @{$status{fixed_versions}})) {
492         $status{"pending"} = 'done';
493     }
494     
495     return \%status;
496 }
497
498 my %_versions;
499 my %_binversioncache = ();
500 sub getversions {
501     my ($pkg, $dist, $arch) = @_;
502     return () unless defined $versionindex;
503     $dist = 'unstable' unless defined $dist;
504
505     unless (tied %_versions) {
506         tie %_versions, 'MLDBM', $versionindex, O_RDONLY
507             or die "can't open versions index: $!";
508     }
509
510         if (!exists($_binversioncache{$pkg})) {
511                 $_binversioncache{$pkg} = \%{ $_versions{$pkg} };
512         }
513         #if ($pkg eq 'atlas3-base') {
514         #       require Data::Dumper;
515         #       print STDERR Data::Dumper::Dumper($_versions{$pkg});
516         #}
517
518         if (defined $arch and exists $_binversioncache{$pkg}{$dist}{$arch}) {
519                 my $ver = $_binversioncache{$pkg}{$dist}{$arch};
520                 if (defined($ver)) {
521                         return $ver;
522                 } else {
523                         return ();
524                 }
525         } else {
526                 my %uniq;
527                 for my $ar (keys %{$_binversioncache{$pkg}{$dist}}) {
528                         $uniq{$_binversioncache{$pkg}{$dist}{$ar}} = 1 unless ($ar eq 'source' or $ar eq 'm68k' or $ar eq 'hurd-i386');
529                 }
530                 if (%uniq) {
531                         return keys %uniq;
532                 } elsif (exists $_binversioncache{$pkg}{$dist}{source}) {
533                         # Maybe this is actually a source package with no corresponding
534                         # binaries?
535                         return $_binversioncache{$pkg}{$dist}{source};
536                 } else {
537                         return ();
538                 }
539         }
540 }
541
542 my %_sourceversioncache = ();
543 sub makesourceversions {
544     my $pkg = shift;
545     my $arch = shift;
546     my %sourceversions;
547
548     for my $version (@_) {
549         if ($version =~ m[/]) {
550             # Already a source version.
551             $sourceversions{$version} = 1;
552         } else {
553             my $cachearch = (defined $arch) ? $arch : '';
554             my $cachekey = "$pkg/$cachearch/$version";
555             if (exists($_sourceversioncache{$cachekey})) {
556                 for my $v (@{$_sourceversioncache{$cachekey}}) {
557                                         $sourceversions{$v} = 1;
558                                 }
559                                 next;
560                         }
561
562                         my @srcinfo = binarytosource($pkg, $version, $arch);
563                         unless (@srcinfo) {
564                                 # We don't have explicit information about the
565                                 # binary-to-source mapping for this version (yet). Since
566                                 # this is a CGI script and our output is transient, we can
567                                 # get away with just looking in the unversioned map; if it's
568                                 # wrong (as it will be when binary and source package
569                                 # versions differ), too bad.
570                                 my $pkgsrc = getpkgsrc();
571                                 if (exists $pkgsrc->{$pkg}) {
572                                         @srcinfo = ([$pkgsrc->{$pkg}, $version]);
573                                 } elsif (getsrcpkgs($pkg)) {
574                                         # If we're looking at a source package that doesn't have
575                                         # a binary of the same name, just try the same version.
576                                         @srcinfo = ([$pkg, $version]);
577                                 } else {
578                                         next;
579                                 }
580                         }
581                         $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
582                         $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
583                 }
584         }
585
586     return sort keys %sourceversions;
587 }
588
589 my %fields = (originator => 'submitter',
590               date => 'date',
591               subject => 'subject',
592               msgid => 'message-id',
593               'package' => 'package',
594               keywords => 'tags',
595               done => 'done',
596               forwarded => 'forwarded-to',
597               mergedwith => 'merged-with',
598               severity => 'severity',
599               owner => 'owner',
600               found_versions => 'found-in',
601               fixed_versions => 'fixed-in',
602               blocks => 'blocks',
603               blockedby => 'blocked-by',
604              );
605
606 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
607 my @rfc1522_fields = qw(originator subject done forwarded owner);
608
609 sub readbug {
610     my ($location) = @_;
611     if (!open(S,$location)) { return undef; }
612
613     my %data;
614     my @lines;
615     my $version = 2;
616     local $_;
617
618     while (<S>) {
619         chomp;
620         push @lines, $_;
621         $version = $1 if /^Format-Version: ([0-9]+)/i;
622     }
623
624     # Version 3 is the latest format version currently supported.
625     return undef if $version > 3;
626
627     my %namemap = reverse %fields;
628     for my $line (@lines) {
629         if ($line =~ /(\S+?): (.*)/) {
630             my ($name, $value) = (lc $1, $2);
631             $data{$namemap{$name}} = $value if exists $namemap{$name};
632         }
633     }
634     for my $field (keys %fields) {
635         $data{$field} = '' unless exists $data{$field};
636     }
637
638     close(S);
639
640     $data{severity} = $gDefaultSeverity if $data{severity} eq '';
641     $data{found_versions} = [split ' ', $data{found_versions}];
642     $data{fixed_versions} = [split ' ', $data{fixed_versions}];
643
644     if ($version < 3) {
645                 for my $field (@rfc1522_fields) {
646                         $data{$field} = decode_rfc1522($data{$field});
647                 }
648     }
649
650     return \%data;
651 }
652
653 sub check_worry {
654     my ($status) = @_;
655
656     if ($status =~ m/^\[[^]]*I/ or
657         $status =~ m/ \[[^]]*X/ or
658         ($status =~ m/ \[[^]]*[OSUE]/ and $status !~ m/ \[[^]]*T/)) {
659         return 0;
660     }
661     return 1;
662 }