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         tie %{$indexes->{$idx}{"tie$fr"}},
 106             MLDBM => $indexes->{$idx}{"index$fr"}.'-new',
 107              O_CREAT|O_TRUNC|O_RDWR, 0644 or
 108                  die qq(Unable to tie $indexes->{$idx}{"index$fr"}-new: $!);
 109     }
 110 }
 111 for my $idx (keys %{$indexes}) {
 112     for my $fn (@{$indexes->{$idx}{files}}) {
 113         next unless defined $fn and length $fn;
 114         if (not -e $fn) {
 115             warn "Missing $idx maintainer file '$fn'";
 116             next;
 117             }
 118             add_to_index($fn,$indexes->{$idx}{tie},
 119                      $indexes->{$idx}{tie_reverse}
 120                     );
 121     }
 122 }
 123
 124 for my $idx (keys %{$indexes}) {
 125     for my $fr ('','_reverse') {
 126         move($indexes->{$idx}{"index$fr"}.'-new',
 127              $indexes->{$idx}{"index$fr"}
 128             );
 129     }
 130 }
 131
 132
 133 sub add_to_index {
 134     my ($fn,$forward,$reverse,$type) = @_;
 135     $type //= 'address';
 136     my $fh;
 137     open($fh,'<',$fn) or
 138         die "Unable to open $fn for reading: $!";
 139     binmode($fh,':encoding(UTF-8)') or
 140         die "Unable to set UTF-8 encoding: $!";
 141     while (<$fh>) {
 142         chomp;
 143         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 144         my ($key,$value) = ($1,$2);
 145         $key = lc($key);
 146         $forward->{$key} = $value;
 147         my @values = $value;
 148         if ($type eq 'address') {
 149             @values = map {lc($_->address)}
 150                 getparsedaddrs($value);
 151         }
 152         for my $m (@values) {
 153             # this is to work around a bug in tied hashes.
 154             my $r = $reverse->{$m} // [];
 155             push @{$r},$key;
 156             $reverse->{$m} = $r;
 157         }
 158     }
 159     close($fh) or
 160         die "Unable to close $fn filehandle: $!";
 161 }
 162
 163
 164
 165 __END__
 166 # Local Variables:
 167 # indent-tabs-mode: nil
 168 # cperl-indent-level: 4
 169 # End: