scripts/gen-indices

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