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 # <@aj> Hackin' on the BTS, Feelin' like it'll take forever; Oh you better
   7 #       hold it's hand, when it dies on names so clever. These are the best
   8 #       bugs of our life. It's up to archive-slash-69, man we were killin'
   9 #       time, we were young and resltess, we needed to unwind. I guess
  10 #       nothin' can last forever - forever, no...
  11
  12 my $config_path = '/etc/debbugs';
  13 my $lib_path = '/usr/lib/debbugs';
  14
  15 require "$config_path/config";
  16 require "$lib_path/errorlib";
  17
  18 use Debbugs::Log;
  19 use Debbugs::MIME;
  20
  21 if (@ARGV != 1) {
  22     print <<EOF;
  23 Usage: $0 db-type
  24
  25 EOF
  26     exit 0;
  27 }
  28
  29 sub getbuginfo ($)
  30 {
  31     my $log = shift;
  32
  33     open LOG, "< $log" or die "Can't open $log: $!";
  34     my @records = read_log_records(*LOG);
  35     close LOG;
  36
  37     my (@found_versions, @fixed_versions);
  38     my (%found_versions, %fixed_versions);
  39
  40     for my $record (@records) {
  41         if ($record->{type} eq 'html') {
  42             # Reassigns zap the found and fixed version list. Reopens will
  43             # zap the fixed list too in the full deployment, but doing that
  44             # here causes problems in case of accidental reopens and
  45             # recloses.
  46             if ($record->{text} =~ /assigned/) {
  47                 @found_versions = ();
  48                 %found_versions = ();
  49                 @fixed_versions = ();
  50                 %fixed_versions = ();
  51             }
  52             next;
  53         }
  54
  55         next unless $record->{type} eq 'autocheck' or
  56                     $record->{type} eq 'incoming-recv';
  57         my $decoded = Debbugs::MIME::parse($record->{text});
  58         next unless defined $decoded;
  59
  60         # Was it sent to -done or -close?
  61         my $closing = 0;
  62         my $firstreceived = $decoded->{header}[0];
  63         if ($firstreceived =~ /\(at [^)]*-(?:done|close)\)/) {
  64             $closing = 1;
  65         }
  66
  67         # Get Version: pseudo-headers.
  68         my $i;
  69         my ($source, $sourcever, $ver);
  70         for ($i = 0; $i < @{$decoded->{body}}; ++$i) {
  71             last if $decoded->{body}[$i] !~ /^(\S+):\s*(.*)/;
  72             my ($fn, $fv) = (lc $1, $2);
  73             if ($fn eq 'source') {
  74                 $source = $fv;
  75             } elsif ($fn eq 'source-version' and
  76                      $fv =~ /^(\d[^,\s]*(?:[,\s]+|$))+/) {
  77                 $sourcever = $fv;
  78             } elsif ($fn eq 'version' and $fv =~ /^(\d[^,\s]*(?:[,\s]+|$))+/) {
  79                 # Deal with reportbug brain-damage.
  80                 next if $fv =~ /^unavailable/i;
  81                 $fv =~ s/;.*//;
  82                 $fv =~ s/ *\(.*\)//;
  83                 # Strip off other random junk at the end of a version.
  84                 $fv =~ s/ +[A-Za-z].*//;
  85                 $ver = $fv;
  86             }
  87         }
  88
  89         my @parsedvers;
  90         if (defined $ver) {
  91             push @parsedvers, split /[,\s]+/, $ver;
  92         } elsif (defined $source and defined $sourcever) {
  93             push @parsedvers, map "$source/$_", split /[,\s]+/, $sourcever;
  94         }
  95
  96         if ($closing) {
  97             for my $v (@parsedvers) {
  98                 push @fixed_versions, $v
  99                     unless exists $fixed_versions{$v};
 100                 $fixed_versions{$v} = 1;
 101                 @found_versions = grep { $_ ne $v } @found_versions;
 102                 delete $found_versions{$v};
 103             }
 104         } else {
 105             for my $v (@parsedvers) {
 106                 push @found_versions, $v
 107                     unless exists $found_versions{$v};
 108                 $found_versions{$v} = 1;
 109                 @fixed_versions = grep { $_ ne $v } @fixed_versions;
 110                 delete $fixed_versions{$v};
 111             }
 112         }
 113
 114         if ($closing) {
 115             # Look for Debian changelogs.
 116             for (; $i < @{$decoded->{body}}; ++$i) {
 117                 if ($decoded->{body}[$i] =~
 118                         /(\w[-+0-9a-z.]+) \(([^\(\) \t]+)\) \S+; urgency=\S+/i) {
 119                     my ($p, $v) = ($1, $2);
 120                     push @fixed_versions, "$p/$v"
 121                         unless exists $fixed_versions{"$p/$v"};
 122                     $fixed_versions{"$p/$v"} = 1;
 123                     @found_versions = grep { $_ ne "$p/$v" } @found_versions;
 124                     delete $found_versions{"$p/$v"};
 125                     last;
 126                 }
 127             }
 128         }
 129     }
 130
 131     return (\@found_versions, \@fixed_versions);
 132 }
 133
 134 sub mergeinto ($$)
 135 {
 136     my ($target, $source) = @_;
 137     my %seen = map { $_ => 1 } @$target;
 138     for my $v (@$source) {
 139         next if exists $seen{$v};
 140         push @$target, $v;
 141         $seen{$v} = 1;
 142     }
 143 }
 144
 145 chdir $gSpoolDir or die "Can't chdir $gSpoolDir: $!";
 146
 147 my $db = $ARGV[0];
 148 opendir DB, $db or die "Can't opendir $db: $!";
 149
 150 while (defined(my $dir = readdir DB)) {
 151     next if $dir =~ /^\.\.?$/ or not -d "$db/$dir";
 152     opendir HASH, "$db/$dir" or die "Can't opendir $db/$dir: $!";
 153
 154     while (defined(my $file = readdir HASH)) {
 155         next unless $file =~ /\.log$/;
 156         next if -z "$db/$dir/$file";
 157         (my $bug = $file) =~ s/\..*//;
 158
 159         $bug =~ /(..)$/;
 160         my $bughash = $1;
 161
 162         print "Processing $bug ...\n" if $ENV{DEBBUGS_VERBOSE};
 163
 164         my ($locks, $status) = lockreadbugmerge($bug, $db);
 165         unless (defined $status) {
 166             unlockreadbugmerge($locks);
 167             next;
 168         }
 169
 170         if (@{$status->{found_versions}} or @{$status->{fixed_versions}}) {
 171             unlockreadbugmerge($locks);
 172             next;
 173         }
 174
 175         my @merges = ();
 176         # Only process the lowest of each set of merged bugs.
 177         if (length $status->{mergedwith}) {
 178             @merges = sort { $a <=> $b } split ' ', $status->{mergedwith};
 179             if ($merges[0] < $bug) {
 180                 unlockreadbugmerge($locks);
 181                 next;
 182             }
 183         }
 184
 185         my ($found_versions, $fixed_versions) = getbuginfo("$db/$dir/$file");
 186
 187         if (length $status->{mergedwith}) {
 188             for my $merge (@merges) {
 189                 $merge =~ /(..)$/;
 190                 my $mergehash = $1;
 191                 my ($mfound, $mfixed) =
 192                     getbuginfo("$db/$mergehash/$merge.log");
 193                 mergeinto($found_versions, $mfound);
 194                 mergeinto($fixed_versions, $mfixed);
 195             }
 196         }
 197
 198         @$fixed_versions = () unless length $status->{done};
 199
 200         for my $out ($bug, @merges) {
 201             if ($out != $bug) {
 202                 filelock("lock/$out");
 203             }
 204             my $outstatus = readbug($out, $db);
 205             $outstatus->{found_versions} = [@$found_versions];
 206             $outstatus->{fixed_versions} = [@$fixed_versions];
 207             writebug($out, $outstatus, $db, 2, 'disable bughook');
 208             if ($out != $bug) {
 209                 unfilelock();
 210             }
 211         }
 212
 213         unlockreadbugmerge($locks);
 214     }
 215
 216     closedir HASH;
 217 }
 218
 219 closedir DB;