scripts/maintainer-indices

   1 #!/usr/bin/perl
   2 # maintainer-indices generates Maintainer.idx and Source.idx files
   3 # and is released under the terms of the GNU GPL version 3, or any
   4 # later version, at your option. See the file README and COPYING for
   5 # more information.
   6 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 maintainer-indices - generates Maintainer.idx and Source.idx files
  18
  19 =head1 SYNOPSIS
  20
  21 maintainer-indices [options]
  22
  23 Options:
  24 --debug, -d debugging level (Default 0)
  25 --help, -h display this help
  26 --man, -m display manual
  27
  28 =head1 OPTIONS
  29
  30 =over
  31
  32 =item B<--debug, -d>
  33
  34 Debug verbosity. (Default 0)
  35
  36 =item B<--help, -h>
  37
  38 Display brief usage information.
  39
  40 =item B<--man, -m>
  41
  42 Display this manual.
  43
  44 =back
  45
  46 =head1 EXAMPLES
  47
  48 C<maintainer-indices>
  49
  50 =cut
  51
  52
  53 use vars qw($DEBUG);
  54 use File::Copy;
  55 use MLDBM qw(DB_File Storable);
  56 $MLDBM::DumpMeth='portable';
  57 use Fcntl;
  58
  59 use Debbugs::Config qw(:config);
  60 use Debbugs::Common qw(lockpid getparsedaddrs);
  61
  62 my %options = (debug           => 0,
  63                help            => 0,
  64                man             => 0,
  65               );
  66
  67 GetOptions(\%options,
  68            'debug|d+','help|h|?','man|m');
  69
  70 pod2usage() if $options{help};
  71 pod2usage({verbose=>2}) if $options{man};
  72
  73 $DEBUG = $options{debug};
  74
  75 my @USAGE_ERRORS;
  76
  77 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  78
  79
  80 my $indexes =
  81    {source => {index => $config{spool_dir}.'/'.'source_maintainers.idx',
  82                index_reverse => $config{spool_dir}.'/'.'source_maintainers_reverse.idx',
  83                files =>
  84                [@config{('source_maintainer_file',
  85                          'source_maintainer_file_override',
  86                          'pseudo_maint_file')}],
  87               },
  88     binary => {index => $config{spool_dir}.'/'.'binary_maintainers.idx',
  89                index_reverse => $config{spool_dir}.'/'.'binary_maintainers_reverse.idx',
  90                files =>
  91                [@config{('maintainer_file',
  92                          'maintainer_file_override',
  93                          'pseudo_maint_file')}],
  94               },
  95    };
  96
  97 if (not lockpid($config{spool_dir}.'/lock/maintainer-indices')) {
  98     print STDERR "Another maintainer-indices is running; stopping\n";
  99     exit 1;
 100 }
 101
 102 # tie new maint/source maint indexes for forward and reverse
 103 for my $idx (keys %{$indexes}) {
 104     for my $fr ('','_reverse') {
 105         $indexes->{$idx}{"tie$fr"} =
 106             create_index_file($indexes->{$idx}{"index$fr"}.'-new');
 107     }
 108 }
 109 for my $idx (keys %{$indexes}) {
 110     for my $fn (@{$indexes->{$idx}{files}}) {
 111         next unless defined $fn and length $fn;
 112         if (not -e $fn) {
 113             warn "Missing $idx maintainer file '$fn'";
 114             next;
 115             }
 116             add_to_index($fn,$indexes->{$idx}{tie},
 117                      $indexes->{$idx}{tie_reverse}
 118                     );
 119     }
 120 }
 121
 122 for my $idx (keys %{$indexes}) {
 123     for my $fr ('','_reverse') {
 124         move($indexes->{$idx}{"index$fr"}.'-new',
 125              $indexes->{$idx}{"index$fr"}
 126             );
 127     }
 128 }
 129
 130 sub create_index_file {
 131     my ($idx_fn) = @_;
 132     my $idx = {};
 133     tie %{$idx},
 134         MLDBM => $idx_fn,
 135         O_CREAT|O_TRUNC|O_RDWR, 0644 or
 136         die qq(Unable to tie $idx_fn: $!);
 137     return $idx;
 138 }
 139
 140
 141 sub add_to_index {
 142     my ($fn,$forward,$reverse,$type) = @_;
 143     $type //= 'address';
 144     my $fh;
 145     open($fh,'<',$fn) or
 146         die "Unable to open $fn for reading: $!";
 147     binmode($fh,':encoding(UTF-8)') or
 148         die "Unable to set UTF-8 encoding: $!";
 149     while (<$fh>) {
 150         chomp;
 151         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 152         my ($key,$value) = ($1,$2);
 153         $key = lc($key);
 154         $forward->{$key} = $value;
 155         my @values = $value;
 156         if ($type eq 'address') {
 157             @values = map {lc($_->address)}
 158                 getparsedaddrs($value);
 159         }
 160         for my $m (@values) {
 161             # this is to work around a bug in tied hashes.
 162             my $r = $reverse->{$m} // [];
 163             push @{$r},$key;
 164             $reverse->{$m} = $r;
 165         }
 166     }
 167     close($fh) or
 168         die "Unable to close $fn filehandle: $!";
 169 }
 170
 171
 172
 173 __END__
 174 # Local Variables:
 175 # indent-tabs-mode: nil
 176 # cperl-indent-level: 4
 177 # End: