examples/debian/postpa/22oldbugs

   1 #! /usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use Debbugs::Config qw(:globals);
   7 use Debbugs::Bugs qw(count_bugs);
   8 use Debbugs::CGI qw(html_escape);
   9 use Debbugs::Status qw(get_bug_status);
  10
  11
  12 # Derived from the 'summary' script in the debbugs package, via
  13 # ~ajt/bugscan.
  14
  15 my $startdate = time;
  16 die "failed to get time: $!" unless defined $startdate;
  17
  18 # check the ctime of '/org/bugs.debian.org/www/stats/oldbugs.html'
  19 use File::stat;
  20 my $ob = stat '/org/bugs.debian.org/www/stats/oldbugs.html';
  21 if (defined $ob and (time - $ob->ctime) < 60*60*12) {
  22   # If less than 12 hours have passed since we last ran this file,
  23   # don't rebuild it.
  24   exit 0;
  25 }
  26
  27 my %excludepackage = ();
  28 for (qw(bugs.debian.org ftp.debian.org lists.debian.org)) {
  29     $excludepackage{$_} = 1;
  30 }
  31
  32 my (%oldpackage, %olddesc, %oldage);
  33
  34 count_bugs(function => sub {
  35     my %d = @_;
  36
  37     # Fast checks.
  38     return () if $d{status} eq 'done' or
  39                  $d{severity} eq 'fixed' or $d{severity} eq 'wishlist';
  40     my %tags = map { $_ => 1 } split ' ', $d{tags};
  41     return () if $tags{fixed};
  42
  43     my $status = get_bug_status($d{bug});
  44     my @merged = sort split ' ', $status->{mergedwith};
  45     return () if @merged and $merged[0] < $d{bug};
  46
  47     # 3600*24*30 (30 days)
  48     my $cmonths = int(($startdate -
  49                        length($status->{date})?$status->{date}:0) /
  50                       2592000);
  51     if ($cmonths >= 24 && !length($status->{forwarded}) &&
  52             !$excludepackage{$d{pkg}}) {
  53         $oldpackage{$d{bug}} = $d{pkg};
  54         $olddesc{$d{bug}} = (length($d{tags}) ? "$d{tags}/" : '') .
  55                             $status->{subject};
  56         $oldage{$d{bug}} = $cmonths;
  57     }
  58 });
  59
  60 my $date = `date`;
  61 chomp $date;
  62
  63 my $nrbugs = keys %oldpackage;
  64
  65 open OLDBUGS, '> /org/bugs.debian.org/www/stats/oldbugs.html.new'
  66     or die "can't open oldbugs.html.new: $!";
  67 print OLDBUGS <<EOF or die "can't write to oldbugs.html.new: $!";
  68 <html><head><title>Bugs Over Two Years Old</title></head>
  69 <body>
  70 <h1>Bugs Over Two Years Old</h1>
  71
  72 <p>Report date: $date<br>
  73 Number of bugs: $nrbugs
  74 </p>
  75 EOF
  76
  77 # TODO: sort optimization would help a lot here
  78 while (%oldpackage) {
  79     my $firstpackage = $oldpackage{(sort { $a <=> $b } keys %oldpackage)[0]};
  80
  81     print OLDBUGS "<p>Package: <a href=\"http://bugs.debian.org/$firstpackage\">$firstpackage</a><br>\n" or
  82          die "can't write to oldbugs.html.new: $!";
  83     # TODO: maintainer
  84     # TODO: comments
  85     for (sort { $a <=> $b } keys %oldpackage) {
  86         if ($oldpackage{$_} eq $firstpackage) {
  87             printf OLDBUGS "<a href=\"http://bugs.debian.org/%d\">%d</a> %s<br>\n", $_, $_, html_escape($olddesc{$_}) or
  88                  die "can't write to oldbugs.html.new: $!";;
  89             # TODO: comments
  90             delete $oldpackage{$_};
  91         }
  92     }
  93     print OLDBUGS "\n";
  94 }
  95
  96 close OLDBUGS or die "can't close oldbugs.html.new: $!";
  97 rename '/org/bugs.debian.org/www/stats/oldbugs.html.new',
  98        '/org/bugs.debian.org/www/stats/oldbugs.html'
  99     or die "can't rename oldbugs.html.new to oldbugs.html: $!";