migrate/debbugs-makeversions

   1 #! /usr/bin/perl -w
   2 # Extract version information from an existing non-versioned database by
   3 # guesswork, based on Version: pseudo-headers and closing mails that look
   4 # like Debian changelogs. The latter in particular is somewhat heuristic.
   5
   6 use strict;
   7 use Debbugs::Log;
   8 use Debbugs::MIME;
   9
  10 if (@ARGV != 2) {
  11     print <<EOF;
  12 Usage: $0 db-directory versions-directory
  13
  14 EOF
  15     exit 0;
  16 }
  17
  18 sub getbuginfo ($)
  19 {
  20     my $log = shift;
  21     print "Processing $log ...\n";
  22
  23     open LOG, "< $log" or die "Can't open $log: $!";
  24     my @records = read_log_records(*LOG);
  25     close LOG;
  26
  27     my (@found_versions, @fixed_versions);
  28     my (%found_versions, %fixed_versions);
  29
  30     for my $record (@records) {
  31         if ($record->{type} eq 'html') {
  32             # Reassigns zap the found and fixed version list. Reopens will
  33             # zap the fixed list too in the full deployment, but doing that
  34             # here causes problems in case of accidental reopens and
  35             # recloses.
  36             if ($record->{text} =~ /assigned/) {
  37                 @found_versions = ();
  38                 %found_versions = ();
  39                 @fixed_versions = ();
  40                 %fixed_versions = ();
  41             }
  42             next;
  43         }
  44
  45         next unless $record->{type} eq 'autocheck' or
  46                     $record->{type} eq 'incoming-recv';
  47         my $decoded = Debbugs::MIME::parse($record->{text});
  48         next unless defined $decoded;
  49
  50         # Was it sent to -done or -close?
  51         my $closing = 0;
  52         my $firstreceived = $decoded->{header}[0];
  53         if ($firstreceived =~ /\(at [^)]*-(?:done|close)\)/) {
  54             $closing = 1;
  55         }
  56
  57         # Get Version: pseudo-headers.
  58         my $i;
  59         for ($i = 0; $i < @{$decoded->{body}}; ++$i) {
  60             last if $decoded->{body}[$i] !~ /^(\S+):\s*(.*)/;
  61             my ($fn, $fv) = (lc $1, $2);
  62             next if $fn ne 'version';
  63             next if $fv !~ /^(\d[^,\s]*(?:[,\s]+|$))+/;
  64             if ($closing) {
  65                 for my $v (split /[,\s]+/, $fv) {
  66                     push @fixed_versions, $v
  67                         unless exists $fixed_versions{$v};
  68                     $fixed_versions{$v} = 1;
  69                     @found_versions = grep { $_ ne $v } @found_versions;
  70                     delete $found_versions{$v};
  71                 }
  72             } else {
  73                 for my $v (split /[,\s]+/, $fv) {
  74                     push @found_versions, $v
  75                         unless exists $found_versions{$v};
  76                     $found_versions{$v} = 1;
  77                     @fixed_versions = grep { $_ ne $v } @fixed_versions;
  78                     delete $fixed_versions{$v};
  79                 }
  80             }
  81         }
  82
  83         if ($closing) {
  84             # Look for Debian changelogs.
  85             for (; $i < @{$decoded->{body}}; ++$i) {
  86                 if ($decoded->{body}[$i] =~
  87                         /\S+ \(([^)]+)\) \S+; urgency=\S+/i) {
  88                     my $v = $1;
  89                     push @fixed_versions, $v
  90                         unless exists $fixed_versions{$v};
  91                     $fixed_versions{$v} = 1;
  92                     @found_versions = grep { $_ ne $v } @found_versions;
  93                     delete $found_versions{$v};
  94                     last;
  95                 }
  96             }
  97         }
  98     }
  99
 100     return (\@found_versions, \@fixed_versions);
 101 }
 102
 103 sub mergeinto ($$)
 104 {
 105     my ($target, $source) = @_;
 106     my %seen = map { $_ => 1 } @$target;
 107     for my $v (@$source) {
 108         next if exists $seen{$v};
 109         push @$target, $v;
 110         $seen{$v} = 1;
 111     }
 112 }
 113
 114 my ($db, $verdb) = @ARGV[0, 1];
 115 opendir DB, $db or die "Can't opendir $db: $!";
 116 unless (-d $verdb) {
 117     mkdir $verdb or die "Can't mkdir $verdb: $!";
 118 }
 119
 120 while (defined(my $dir = readdir DB)) {
 121     next if $dir =~ /^\.\.?$/ or not -d "$db/$dir";
 122     opendir HASH, "$db/$dir" or die "Can't opendir $db/$dir: $!";
 123
 124     while (defined(my $file = readdir HASH)) {
 125         next unless $file =~ /\.log$/;
 126         next if -z "$db/$dir/$file";
 127         (my $bug = $file) =~ s/\..*//;
 128
 129         $bug =~ /(..)$/;
 130         my $bughash = $1;
 131         next if -e "$verdb/$bughash/$bug.versions" and
 132                 (stat "$verdb/$bughash/$bug.versions")[9] >=
 133                     (stat "$db/$dir/$file")[9];
 134
 135         open STATUS, "$db/$dir/$bug.status" or next;
 136         <STATUS> for 1 .. 6;    # done is field 7
 137         chomp (my $done = <STATUS>);
 138         <STATUS>;               # mergedwith is field 9
 139         chomp (my $mergedwith = <STATUS>);
 140         close STATUS;
 141
 142         my ($found_versions, $fixed_versions) = getbuginfo("$db/$dir/$file");
 143
 144         if (length $mergedwith) {
 145             for my $merge (split ' ', $mergedwith) {
 146                 $merge =~ /(..)$/;
 147                 my $mergehash = $1;
 148                 my ($mfound, $mfixed) =
 149                     getbuginfo("$db/$mergehash/$merge.log");
 150                 mergeinto($found_versions, $mfound);
 151                 mergeinto($fixed_versions, $mfixed);
 152             }
 153         }
 154
 155         @$fixed_versions = () unless length $done;
 156
 157         for my $out ($bug, (split ' ', $mergedwith)) {
 158             $out =~ /(..)$/;
 159             my $outhash = $1;
 160
 161             unless (-d "$verdb/$outhash") {
 162                 mkdir "$verdb/$outhash" or die "Can't mkdir $verdb/$outhash: $!";
 163             }
 164
 165             open VERSIONS, "> $verdb/$outhash/$out.versions"
 166                 or die "Can't open $verdb/$outhash/$out.versions: $!";
 167             print VERSIONS "Found-in: @$found_versions\n";
 168             print VERSIONS "Fixed-in: @$fixed_versions\n";
 169             close VERSIONS;
 170         }
 171     }
 172
 173     closedir HASH;
 174 }
 175
 176 closedir DB;