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