examples/debian/versions/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         my ($source, $sourcever, $ver);
  60         for ($i = 0; $i < @{$decoded->{body}}; ++$i) {
  61             last if $decoded->{body}[$i] !~ /^(\S+):\s*(.*)/;
  62             my ($fn, $fv) = (lc $1, $2);
  63             if ($fn eq 'source') {
  64                 $source = $fv;
  65             } elsif ($fn eq 'source-version' and
  66                      $fv =~ /^(\d[^,\s]*(?:[,\s]+|$))+/) {
  67                 $sourcever = $fv;
  68             } elsif ($fn eq 'version' and $fv =~ /^(\d[^,\s]*(?:[,\s]+|$))+/) {
  69                 # Deal with reportbug brain-damage.
  70                 next if $fv =~ /^unavailable/i;
  71                 $fv =~ s/;.*//;
  72                 $fv =~ s/ *\(.*\)//;
  73                 $ver = $fv;
  74             }
  75         }
  76
  77         my @parsedvers;
  78         if (defined $ver) {
  79             push @parsedvers, split /[,\s]+/, $ver;
  80         } elsif (defined $source and defined $sourcever) {
  81             push @parsedvers, map "$source/$_", split /[,\s]+/, $sourcever;
  82         }
  83
  84         if ($closing) {
  85             for my $v (@parsedvers) {
  86                 push @fixed_versions, $v
  87                     unless exists $fixed_versions{$v};
  88                 $fixed_versions{$v} = 1;
  89                 @found_versions = grep { $_ ne $v } @found_versions;
  90                 delete $found_versions{$v};
  91             }
  92         } else {
  93             for my $v (@parsedvers) {
  94                 push @found_versions, $v
  95                     unless exists $found_versions{$v};
  96                 $found_versions{$v} = 1;
  97                 @fixed_versions = grep { $_ ne $v } @fixed_versions;
  98                 delete $fixed_versions{$v};
  99             }
 100         }
 101
 102         if ($closing) {
 103             # Look for Debian changelogs.
 104             for (; $i < @{$decoded->{body}}; ++$i) {
 105                 if ($decoded->{body}[$i] =~
 106                         /(\w[-+0-9a-z.]+) \(([^\(\) \t]+)\) \S+; urgency=\S+/i) {
 107                     my ($p, $v) = ($1, $2);
 108                     push @fixed_versions, "$p/$v"
 109                         unless exists $fixed_versions{"$p/$v"};
 110                     $fixed_versions{"$p/$v"} = 1;
 111                     @found_versions = grep { $_ ne "$p/$v" } @found_versions;
 112                     delete $found_versions{"$p/$v"};
 113                     last;
 114                 }
 115             }
 116         }
 117     }
 118
 119     return (\@found_versions, \@fixed_versions);
 120 }
 121
 122 sub mergeinto ($$)
 123 {
 124     my ($target, $source) = @_;
 125     my %seen = map { $_ => 1 } @$target;
 126     for my $v (@$source) {
 127         next if exists $seen{$v};
 128         push @$target, $v;
 129         $seen{$v} = 1;
 130     }
 131 }
 132
 133 my ($db, $verdb) = @ARGV[0, 1];
 134 opendir DB, $db or die "Can't opendir $db: $!";
 135 unless (-d $verdb) {
 136     mkdir $verdb or die "Can't mkdir $verdb: $!";
 137 }
 138
 139 while (defined(my $dir = readdir DB)) {
 140     next if $dir =~ /^\.\.?$/ or not -d "$db/$dir";
 141     opendir HASH, "$db/$dir" or die "Can't opendir $db/$dir: $!";
 142
 143     while (defined(my $file = readdir HASH)) {
 144         next unless $file =~ /\.log$/;
 145         next if -z "$db/$dir/$file";
 146         (my $bug = $file) =~ s/\..*//;
 147
 148         $bug =~ /(..)$/;
 149         my $bughash = $1;
 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;