scripts/gen-indices

   1 #!/usr/bin/perl
   2
   3 # Generates by-*.idx files for the CGI scripts
   4 # Copyright (c) 2005/08/03 Anthony Towns
   5 # GPL v2
   6
   7 use DB_File;
   8 use MLDBM qw(DB_FILE Storable);
   9 use Fcntl qw/O_RDWR O_CREAT O_TRUNC/;
  10 use File::Copy;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 use warnings;
  16 use strict;
  17
  18 use File::stat;
  19 use List::Util qw(min);
  20
  21 =head1 NAME
  22
  23 gen-indices - Generates index files for the cgi scripts
  24
  25 =head1 SYNOPSIS
  26
  27  gen-indices [options]
  28
  29  Options:
  30   --index-path path to index location
  31   --quick update changed bugs
  32   --debug, -d debugging level (Default 0)
  33   --help, -h display this help
  34   --man, -m display manual
  35
  36 =head1 OPTIONS
  37
  38 =over
  39
  40 =itme B<--quick>
  41
  42 Only update changed bugs
  43
  44 =item B<--debug, -d>
  45
  46 Debug verbosity. (Default 0)
  47
  48 =item B<--help, -h>
  49
  50 Display brief useage information.
  51
  52 =item B<--man, -m>
  53
  54 Display this manual.
  55
  56 =back
  57
  58 =head1 EXAMPLES
  59
  60
  61 =cut
  62
  63 # Use portable Storable images
  64 $MLDBM::DumpMeth=q(portable);
  65
  66
  67 my %options = (debug           => 0,
  68                help            => 0,
  69                man             => 0,
  70                quick           => 0,
  71                index_path      => undef,
  72                );
  73
  74 GetOptions(\%options,'quick!','index_path|index-path=s','debug|d+','help|h|?','man|m') or pod2usage(2);
  75 pod2usage(1) if $options{help};
  76 pod2usage(-verbose=>2) if $options{man};
  77
  78 use Debbugs::Config qw(:config);
  79 use Debbugs::Common qw(getparsedaddrs getbugcomponent lockpid);
  80 use Debbugs::Status qw(readbug);
  81
  82 chdir($config{spool_dir}) or die "chdir $config{spool_dir} failed: $!";
  83
  84 my $verbose = $options{debug};
  85 my $indexdest = $options{index_path} || $config{spool_dir};
  86
  87 my $initialdir = "db-h";
  88 my $suffix = "";
  89
  90 if (defined $ARGV[0] and $ARGV[0] eq "archive") {
  91     $initialdir = "archive";
  92     $suffix = "-arc";
  93 }
  94
  95 if (not lockpid($config{spool_dir}.'/lock/gen-indices')) {
  96      if ($options{quick}) {
  97           # If this is a quick run, just exit
  98           print STDERR "Another gen-indices is running; stopping\n" if $verbose;
  99           exit 0;
 100      }
 101      print STDERR "Another gen-indices is running; stopping\n";
 102      exit 1;
 103 }
 104
 105 # NB: The reverse index is special; it's used to clean up during updates to bugs
 106 my @indexes = ('package', 'tag', 'severity','owner','submitter-email','status','reverse');
 107 my $indexes;
 108 my %slow_index = ();
 109 my %fast_index = ();
 110 if (not $options{quick}) {
 111      # We'll trade memory for speed here if we're not doing a quick rebuild
 112      for my $indexes (@indexes) {
 113           $fast_index{$indexes} = {};
 114      }
 115      $indexes = \%fast_index;
 116 }
 117 else {
 118      $indexes = \%slow_index;
 119 }
 120 my $time = undef;
 121 my $start_time = time;
 122 for my $i (@indexes) {
 123         $slow_index{$i} = {};
 124         if ($options{quick}) {
 125              if (-e "$indexdest/by-$i${suffix}.idx") {
 126                   system('cp','-a',"$indexdest/by-$i${suffix}.idx","$indexdest/by-$i${suffix}.idx.new") == 0
 127                        or die "Error creating the new index";
 128                   my $stat = stat("$indexdest/by-$i${suffix}.idx") or die "Unable to stat $indexdest/by-$i${suffix}.idx";
 129                   $time = defined $time ? min($time,$stat->mtime) : $stat->mtime;
 130              }
 131              tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
 132                   O_RDWR|O_CREAT, 0666
 133                        or die "$0: can't create by-$i$suffix-idx.new: $!";
 134         }
 135         else {
 136              tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
 137                   O_RDWR|O_CREAT|O_TRUNC, 0666
 138                        or die "$0: can't create by-$i$suffix-idx.new: $!";
 139
 140         }
 141         $time = 0 if not defined $time;
 142 }
 143
 144 sub addbugtoindex {
 145      my ($index, $bug, @values) = @_;
 146
 147      if (exists $indexes->{reverse}{"$index $bug"}) {
 148           # We do this insanity to work around a "feature" in MLDBM
 149           for my $key (@{$indexes->{reverse}{"$index $bug"}}) {
 150                my $temp = $indexes->{$index}{$key};
 151                delete $temp->{$bug};
 152                $indexes->{$index}{$key} = $temp;
 153                $indexes->{$index}{"count $key"}--;
 154           }
 155           delete $indexes->{reverse}{"$index $bug"};
 156      }
 157      for my $key (@values) {
 158           $indexes->{$index}->{"count $key"}++;
 159           # We do this insanity to work around a "feature" in MLDBM
 160           my $temp = $indexes->{$index}->{$key};
 161           $temp->{$bug} = 1;
 162           $indexes->{$index}->{$key} = $temp;
 163      }
 164      $indexes->{reverse}{"$index $bug"} = [@values];
 165 }
 166
 167 sub emailfromrfc822 {
 168         my $email = shift;
 169         $email =~ s/\s*\(.*\)\s*//;
 170         $email = $1 if ($email =~ m/<(.*)>/);
 171         return $email;
 172 }
 173
 174 my $cnt = 0;
 175
 176 my @dirs = ($initialdir);
 177 while (my $dir = shift @dirs) {
 178         printf "Doing dir %s ...\n", $dir if $verbose;
 179
 180         opendir(DIR, "$dir/.") or die "opendir $dir: $!";
 181         my @subdirs = readdir(DIR);
 182         closedir(DIR);
 183
 184         my @list = map { m/^(\d+)\.summary$/?($1):() } @subdirs;
 185         push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
 186
 187         for my $bug (@list) {
 188                 print "Up to $cnt bugs...\n" if (++$cnt % 100 == 0 && $verbose);
 189                 my $stat = stat(getbugcomponent($bug,'summary',$initialdir));
 190                 if (not defined $stat) {
 191                      print STDERR "Unable to stat $bug $!\n";
 192                      next;
 193                 }
 194                 next if $stat->mtime < $time;
 195                 my $fdata = readbug($bug, $initialdir);
 196                 addbugtoindex("package", $bug, split /[\s,]+/, $fdata->{"package"});
 197                 addbugtoindex("tag", $bug, split /[\s,]+/, $fdata->{"keywords"});
 198                 addbugtoindex('submitter-email', $bug,
 199                               map {lc($_->address)} getparsedaddrs($fdata->{originator}));
 200                 addbugtoindex("severity", $bug, $fdata->{"severity"});
 201                 addbugtoindex("owner", $bug,
 202                               map {lc($_->address)} getparsedaddrs($fdata->{"owner"}));
 203         }
 204 }
 205
 206 if (not $options{quick}) {
 207      # put the fast index into the slow index
 208      for my $key1 (keys %fast_index) {
 209           for my $key2 (keys %{$fast_index{$key1}}) {
 210                $slow_index{$key1}{$key2} = $fast_index{$key1}{$key2};
 211           }
 212           print "Dealt with index $key1\n" if $verbose;
 213      }
 214 }
 215
 216
 217 for my $i (@indexes) {
 218         untie %{$slow_index{$i}};
 219         move("$indexdest/by-$i$suffix.idx.new", "$indexdest/by-$i$suffix.idx");
 220         # We do this, because old versions of touch don't support -d '@epoch'
 221         system('touch','-d',"1/1/1970 UTC + ${start_time}secs","$indexdest/by-$i$suffix.idx");
 222 }
 223
 224 unlink($config{spool_dir}.'/lock/gen-indices')