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
  22     open LOG, "< $log" or die "Can't open $log: $!";
  23     my @records = read_log_records(*LOG);
  24     close LOG;
  25
  26     my (@found_versions, @fixed_versions);
  27     my (%found_versions, %fixed_versions);
  28
  29     for my $record (@records) {
  30         if ($record->{type} eq 'html') {
  31             # Reassigns zap the found and fixed version list. Reopens will
  32             # zap the fixed list too in the full deployment, but doing that
  33             # here causes problems in case of accidental reopens and
  34             # recloses.
  35             if ($record->{text} =~ /assigned/) {
  36                 @found_versions = ();
  37                 %found_versions = ();
  38                 @fixed_versions = ();
  39                 %fixed_versions = ();
  40             }
  41             next;
  42         }
  43
  44         next unless $record->{type} eq 'autocheck' or
  45                     $record->{type} eq 'incoming-recv';
  46         my $decoded = Debbugs::MIME::parse($record->{text});
  47         next unless defined $decoded;
  48
  49         # Was it sent to -done or -close?
  50         my $closing = 0;
  51         my $firstreceived = $decoded->{header}[0];
  52         if ($firstreceived =~ /\(at [^)]*-(?:done|close)\)/) {
  53             $closing = 1;
  54         }
  55
  56         # Get Version: pseudo-headers.
  57         my $i;
  58         my ($source, $sourcever, $ver);
  59         for ($i = 0; $i < @{$decoded->{body}}; ++$i) {
  60             last if $decoded->{body}[$i] !~ /^(\S+):\s*(.*)/;
  61             my ($fn, $fv) = (lc $1, $2);
  62             if ($fn eq 'source') {
  63                 $source = $fv;
  64             } elsif ($fn eq 'source-version' and
  65                      $fv =~ /^(\d[^,\s]*(?:[,\s]+|$))+/) {
  66                 $sourcever = $fv;
  67             } elsif ($fn eq 'version' and $fv =~ /^(\d[^,\s]*(?:[,\s]+|$))+/) {
  68                 # Deal with reportbug brain-damage.
  69                 next if $fv =~ /^unavailable/i;
  70                 $fv =~ s/;.*//;
  71                 $fv =~ s/ *\(.*\)//;
  72                 $ver = $fv;
  73             }
  74         }
  75
  76         my @parsedvers;
  77         if (defined $ver) {
  78             push @parsedvers, split /[,\s]+/, $ver;
  79         } elsif (defined $source and defined $sourcever) {
  80             push @parsedvers, map "$source/$_", split /[,\s]+/, $sourcever;
  81         }
  82
  83         if ($closing) {
  84             for my $v (@parsedvers) {
  85                 push @fixed_versions, $v
  86                     unless exists $fixed_versions{$v};
  87                 $fixed_versions{$v} = 1;
  88                 @found_versions = grep { $_ ne $v } @found_versions;
  89                 delete $found_versions{$v};
  90             }
  91         } else {
  92             for my $v (@parsedvers) {
  93                 push @found_versions, $v
  94                     unless exists $found_versions{$v};
  95                 $found_versions{$v} = 1;
  96                 @fixed_versions = grep { $_ ne $v } @fixed_versions;
  97                 delete $fixed_versions{$v};
  98             }
  99         }
 100
 101         if ($closing) {
 102             # Look for Debian changelogs.
 103             for (; $i < @{$decoded->{body}}; ++$i) {
 104                 if ($decoded->{body}[$i] =~
 105                         /(\w[-+0-9a-z.]+) \(([^\(\) \t]+)\) \S+; urgency=\S+/i) {
 106                     my ($p, $v) = ($1, $2);
 107                     push @fixed_versions, "$p/$v"
 108                         unless exists $fixed_versions{"$p/$v"};
 109                     $fixed_versions{"$p/$v"} = 1;
 110                     @found_versions = grep { $_ ne "$p/$v" } @found_versions;
 111                     delete $found_versions{"$p/$v"};
 112                     last;
 113                 }
 114             }
 115         }
 116     }
 117
 118     return (\@found_versions, \@fixed_versions);
 119 }
 120
 121 sub mergeinto ($$)
 122 {
 123     my ($target, $source) = @_;
 124     my %seen = map { $_ => 1 } @$target;
 125     for my $v (@$source) {
 126         next if exists $seen{$v};
 127         push @$target, $v;
 128         $seen{$v} = 1;
 129     }
 130 }
 131
 132 my ($db, $verdb) = @ARGV[0, 1];
 133 opendir DB, $db or die "Can't opendir $db: $!";
 134 unless (-d $verdb) {
 135     mkdir $verdb or die "Can't mkdir $verdb: $!";
 136 }
 137
 138 while (defined(my $dir = readdir DB)) {
 139     next if $dir =~ /^\.\.?$/ or not -d "$db/$dir";
 140     opendir HASH, "$db/$dir" or die "Can't opendir $db/$dir: $!";
 141
 142     while (defined(my $file = readdir HASH)) {
 143         next unless $file =~ /\.log$/;
 144         next if -z "$db/$dir/$file";
 145         (my $bug = $file) =~ s/\..*//;
 146
 147         $bug =~ /(..)$/;
 148         my $bughash = $1;
 149         # For incremental updates.
 150         #next if -e "$verdb/$bughash/$bug.versions" and
 151         #       (stat "$verdb/$bughash/$bug.versions")[9] >=
 152         #           (stat "$db/$dir/$file")[9];
 153
 154         print "Processing $bug ...\n" if $ENV{DEBBUGS_VERBOSE};
 155
 156         open STATUS, "$db/$dir/$bug.status" or next;
 157         <STATUS> for 1 .. 6;    # done is field 7
 158         chomp (my $done = <STATUS>);
 159         <STATUS>;               # mergedwith is field 9
 160         chomp (my $mergedwith = <STATUS>);
 161         close STATUS;
 162
 163         my ($found_versions, $fixed_versions) = getbuginfo("$db/$dir/$file");
 164
 165         if (length $mergedwith) {
 166             for my $merge (split ' ', $mergedwith) {
 167                 $merge =~ /(..)$/;
 168                 my $mergehash = $1;
 169                 my ($mfound, $mfixed) =
 170                     getbuginfo("$db/$mergehash/$merge.log");
 171                 mergeinto($found_versions, $mfound);
 172                 mergeinto($fixed_versions, $mfixed);
 173             }
 174         }
 175
 176         @$fixed_versions = () unless length $done;
 177
 178         for my $out ($bug, (split ' ', $mergedwith)) {
 179             $out =~ /(..)$/;
 180             my $outhash = $1;
 181
 182             unless (-d "$verdb/$outhash") {
 183                 mkdir "$verdb/$outhash" or die "Can't mkdir $verdb/$outhash: $!";
 184             }
 185
 186             open VERSIONS, "> $verdb/$outhash/$out.versions"
 187                 or die "Can't open $verdb/$outhash/$out.versions: $!";
 188             print VERSIONS "Found-in: @$found_versions\n";
 189             print VERSIONS "Fixed-in: @$fixed_versions\n";
 190             close VERSIONS;
 191         }
 192     }
 193
 194     closedir HASH;
 195 }
 196
 197 closedir DB;