scripts/gen-indices.in

   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);
  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 # NB: The reverse index is special; it's used to clean up during updates to bugs
  96 my @indexes = ('package', 'tag', 'severity','owner','submitter-email','reverse');
  97 my $indexes;
  98 my %slow_index = ();
  99 my %fast_index = ();
 100 if (not $options{quick}) {
 101      # We'll trade memory for speed here if we're not doing a quick rebuild
 102      for my $indexes (@indexes) {
 103           $fast_index{$indexes} = {};
 104      }
 105      $indexes = \%fast_index;
 106 }
 107 else {
 108      $indexes = \%slow_index;
 109 }
 110 my $time = undef;
 111 my $start_time = time;
 112 for my $i (@indexes) {
 113         $slow_index{$i} = {};
 114         if ($options{quick}) {
 115              if (-e "$indexdest/by-$i${suffix}.idx") {
 116                   system('cp','-a',"$indexdest/by-$i${suffix}.idx","$indexdest/by-$i${suffix}.idx.new") == 0
 117                        or die "Error creating the new index";
 118                   my $stat = stat("$indexdest/by-$i${suffix}.idx") or die "Unable to stat $indexdest/by-$i${suffix}.idx";
 119                   $time = defined $time ? min($time,$stat->mtime) : $stat->mtime;
 120              }
 121              tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
 122                   O_RDWR|O_CREAT, 0666
 123                        or die "$0: can't create by-$i$suffix-idx.new: $!";
 124         }
 125         else {
 126              tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
 127                   O_RDWR|O_CREAT|O_TRUNC, 0666
 128                        or die "$0: can't create by-$i$suffix-idx.new: $!";
 129
 130         }
 131         $time = 0 if not defined $time;
 132 }
 133
 134 sub addbugtoindex {
 135      my ($index, $bug, @values) = @_;
 136
 137      if (exists $indexes->{reverse}{"$index $bug"}) {
 138           # We do this insanity to work around a "feature" in MLDBM
 139           for my $key (@{$indexes->{reverse}{"$index $bug"}}) {
 140                my $temp = $indexes->{$index}{$key};
 141                delete $temp->{$bug};
 142                $indexes->{$index}{$key} = $temp;
 143                $indexes->{$index}{"count $key"}--;
 144           }
 145           delete $indexes->{reverse}{"$index $bug"};
 146      }
 147      for my $key (@values) {
 148           $indexes->{$index}->{"count $key"}++;
 149           # We do this insanity to work around a "feature" in MLDBM
 150           my $temp = $indexes->{$index}->{$key};
 151           $temp->{$bug} = 1;
 152           $indexes->{$index}->{$key} = $temp;
 153      }
 154      $indexes->{reverse}{"$index $bug"} = [@values];
 155 }
 156
 157 sub emailfromrfc822 {
 158         my $email = shift;
 159         $email =~ s/\s*\(.*\)\s*//;
 160         $email = $1 if ($email =~ m/<(.*)>/);
 161         return $email;
 162 }
 163
 164 my $cnt = 0;
 165
 166 my @dirs = ($initialdir);
 167 while (my $dir = shift @dirs) {
 168         printf "Doing dir %s ...\n", $dir if $verbose;
 169
 170         opendir(DIR, "$dir/.") or die "opendir $dir: $!\n";
 171         my @subdirs = readdir(DIR);
 172         closedir(DIR);
 173
 174         my @list = map { m/^(\d+)\.summary$/?($1):() } @subdirs;
 175         push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
 176
 177         for my $bug (@list) {
 178                 print "Up to $cnt bugs...\n" if (++$cnt % 100 == 0 && $verbose);
 179                 my $stat = stat(getbugcomponent($bug,'summary'));
 180                 next if $stat->mtime < $time;
 181                 my $fdata = readbug($bug, $initialdir);
 182                 addbugtoindex("package", $bug, split /[\s,]+/, $fdata->{"package"});
 183                 addbugtoindex("tag", $bug, split /[\s,]+/, $fdata->{"keywords"});
 184                 addbugtoindex('submitter-email', $bug,
 185                               map {lc($_->address)} getparsedaddrs($fdata->{originator}));
 186                 addbugtoindex("severity", $bug, $fdata->{"severity"});
 187                 addbugtoindex("owner", $bug,
 188                               map {lc($_->address)} getparsedaddrs($fdata->{"owner"}));
 189         }
 190 }
 191
 192 if (not $options{quick}) {
 193      # put the fast index into the slow index
 194      for my $key1 (keys %fast_index) {
 195           for my $key2 (keys %{$fast_index{$key1}}) {
 196                $slow_index{$key1}{$key2} = $fast_index{$key1}{$key2};
 197           }
 198           print "Dealt with index $key1\n" if $verbose;
 199      }
 200 }
 201
 202
 203 for my $i (@indexes) {
 204         untie %{$slow_index{$i}};
 205         move("$indexdest/by-$i$suffix.idx.new", "$indexdest/by-$i$suffix.idx");
 206         # We do this, because old versions of touch don't support -d '@epoch'
 207         system('touch','-d',"1/1/1970 UTC + ${start_time}secs","$indexdest/by-$i$suffix.idx");
 208 }
 209