diplodocus.org Git - minc/blob - msgiddb

   1 #!/usr/local/bin/perl
   2
   3 =head1 NAME
   4
   5 B<msgiddb> - update database mapping Message-ID to message file names
   6
   7 =head1 SYNOPSIS
   8
   9 B<msgiddb> I<dbfile> I<message-files>
  10
  11 =head1 DESCRIPTION
  12
  13 For each I<message-file>, read its Message-ID and use as key in I<dbfile>.
  14 Check for its presence in the JSON-serialized list stored as the value;
  15 if absent, append and update the db.
  16
  17 For messages with multiple Message-ID fields, concatenate all the values and use
  18 that as the key.
  19
  20 I<message-file> names are used exactly; no path components are stripped.
  21
  22 =cut
  23
  24 use strict;
  25 use warnings;
  26 use v5.14;
  27
  28 use DB_File;
  29 use JSON::PP;
  30 use List::Util 'first';
  31
  32 use FindBin;
  33 use lib $FindBin::Bin;
  34
  35 require 'minc';
  36
  37 sub push_dblist {
  38     my $db            = shift;
  39     my $key           = shift;
  40     my $value         = shift;
  41     my $current_value = $db->{$key};
  42     my $values;
  43     if ($current_value) {
  44         $values = decode_json($current_value);
  45         if ( first { defined($_) } @$values ) {
  46             return;
  47         }
  48     }
  49     else {
  50         my @tmp;
  51         $values = \@tmp;
  52     }
  53     push( @$values, $value );
  54     $db->{$key} = encode_json($values);
  55 }
  56
  57 if ( !caller() ) {
  58     my $dbfn = shift;
  59     tie( my %db, 'DB_File', $dbfn ) or die("tie(DB_File, $dbfn): $!");
  60
  61     my $errors = 0;
  62     for my $fn (@ARGV) {
  63         my $msgids = get_headers($fn)->{'message-id'};
  64         if ( !( defined($msgids) && @$msgids ) ) {
  65             say STDERR "$fn has no message-id";
  66             $errors++;
  67             next;
  68         }
  69         my $msgid = join( '', @$msgids );
  70         push_dblist( \%db, $msgid, $fn );
  71     }
  72     exit($errors);
  73 }