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 strict;
   8
   9 use DB_File;
  10 use Fcntl qw/O_RDWR O_CREAT O_TRUNC/;
  11 use File::Copy;
  12
  13 use Getopt::Long;
  14 use Pod::Usage;
  15
  16 use File::stat;
  17 use List::Util qw(min);
  18
  19 =head1 NAME
  20
  21 gen-indices - Generates index files for the cgi scripts
  22
  23 =head1 SYNOPSIS
  24
  25  gen-indices [options]
  26
  27  Options:
  28   --quick update changed bugs
  29   --debug, -d debugging level (Default 0)
  30   --help, -h display this help
  31   --man, -m display manual
  32
  33 =head1 OPTIONS
  34
  35 =over
  36
  37 =itme B<--quick>
  38
  39 Only update changed bugs
  40
  41 =item B<--debug, -d>
  42
  43 Debug verbosity. (Default 0)
  44
  45 =item B<--help, -h>
  46
  47 Display brief useage information.
  48
  49 =item B<--man, -m>
  50
  51 Display this manual.
  52
  53 =back
  54
  55 =head1 EXAMPLES
  56
  57
  58 =cut
  59
  60
  61 my %options = (debug           => 0,
  62                help            => 0,
  63                man             => 0,
  64                quick           => 0,
  65                );
  66
  67 GetOptions(\%options,'quick!','debug|d+','help|h|?','man|m') or pod2usage(2);
  68
  69
  70 require '/etc/debbugs/config';
  71 require '/org/bugs.debian.org/scripts/errorlib';
  72
  73 chdir('/org/bugs.debian.org/spool') or die "chdir spool: $!\n";
  74
  75 my $verbose = $options{debug};
  76 my $indexdest = "/org/bugs.debian.org/spool";
  77
  78 my $initialdir = "db-h";
  79 my $suffix = "";
  80
  81 if ($ARGV[0] eq "archive") {
  82     $initialdir = "archive";
  83     $suffix = "-arc";
  84 }
  85
  86 my @indexes = ('package', 'tag', 'severity', 'submitter-email');
  87 my %index = ();
  88 my $time = undef;
  89 my $start_time = time;
  90 for my $i (@indexes) {
  91         %{$index{$i}} = {};
  92         if ($options{quick}) {
  93              if (-e "$indexdest/by-$i${suffix}.idx") {
  94                   system('cp','-a',"$indexdest/by-$i${suffix}.idx","$indexdest/by-$i${suffix}.idx.new") == 0
  95                        or die "Error creating the new index";
  96                   my $stat = stat("$indexdest/by-$i${suffix}.idx") or die "Unable to stat $indexdest/by-$i${suffix}.idx";
  97                   $time = defined $time ? min($time,$stat->mtime) : $stat->mtime;
  98              }
  99              tie %{$index{$i}}, DB_File => "$indexdest/by-$i$suffix.idx.new",
 100                   O_RDWR|O_CREAT, 0666
 101                        or die "$0: can't create by-$i$suffix-idx.new: $!";
 102         }
 103         else {
 104              tie %{$index{$i}}, DB_File => "$indexdest/by-$i$suffix.idx.new",
 105                   O_RDWR|O_CREAT|O_TRUNC, 0666
 106                        or die "$0: can't create by-$i$suffix-idx.new: $!";
 107
 108         }
 109         $time = 0 if not defined $time;
 110 }
 111
 112 sub addbugtoindex {
 113         my ($i, $k, $bug) = @_;
 114
 115         my $cnt = 0;
 116         if (exists $index{$i}->{"count $k"}) {
 117                 $cnt = unpack 'N', $index{$i}->{"count $k"};
 118         }
 119         $index{$i}->{"count $k"} = (pack 'N', 1+$cnt);
 120         my $which = $cnt - ($cnt % 100);
 121         $index{$i}->{"$which $k"} = '' unless defined $index{$i}->{"$which $k"};
 122         $index{$i}->{"$which $k"} .= (pack 'N', $bug);
 123 }
 124
 125 sub emailfromrfc822 {
 126         my $email = shift;
 127         $email =~ s/\s*\(.*\)\s*//;
 128         $email = $1 if ($email =~ m/<(.*)>/);
 129         return $email;
 130 }
 131
 132 #my $cnt = 0;
 133
 134 my @dirs = ($initialdir);
 135 while (my $dir = shift @dirs) {
 136         printf "Doing dir %s ...\n", $dir if $verbose;
 137
 138         opendir(DIR, "$dir/.") or die "opendir $dir: $!\n";
 139         my @subdirs = readdir(DIR);
 140         closedir(DIR);
 141
 142         my @list = map { m/^(\d+)\.summary$/?($1):() } @subdirs;
 143         push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
 144
 145         for my $f (@list) {
 146                 print "Up to $cnt bugs...\n" if (++$cnt % 100 == 0 && $verbose);
 147                 my $stat = stat(getbugcomponent($f,'summary'));
 148                 next if $stat->mtime < $time;
 149                 my $fdata = readbug($f, $initialdir);
 150                 for my $p (split /[\s,]+/, $fdata->{"package"}) {
 151                   addbugtoindex("package", $p, $f);
 152                 }
 153                 for my $t (split /[\s,]+/, $fdata->{"keywords"}) {
 154                   addbugtoindex("tag", $t, $f);
 155                 }
 156                 addbugtoindex('submitter-email',
 157                         emailfromrfc822($fdata->{"originator"}), $f);
 158                 addbugtoindex("severity", $fdata->{"severity"}, $f);
 159         }
 160 }
 161
 162 for my $i (@indexes) {
 163         untie %{$indexes{$i}};
 164         move("$indexdest/by-$i$suffix.idx.new", "$indexdest/by-$i$suffix.idx");
 165         system('touch','-d',"1/1/1970 + ${start_time}secs","$indexdest/by-$i$suffix.idx");
 166 }