tools/cm-reparent.pl

   1 #!/usr/bin/perl
   2
   3 use 5.14.1;
   4 use warnings;
   5
   6 our $VERSION = "1.05 - 2018-10-08";
   7 our $cmd = $0 =~ s{.*/}{}r;
   8
   9 sub usage {
  10     my $err = shift and select STDERR;
  11     say "usage: $cmd file ...";
  12     exit $err;
  13     } # usage
  14
  15 use Date::Parse;
  16 use Getopt::Long;
  17 GetOptions (
  18     "help|?"    => sub { usage (0); },
  19     "V|version" => sub { say "$cmd [$VERSION]"; exit 0; },
  20     ) or usage (1);
  21
  22 my $p;
  23 my %f;
  24 foreach my $fn (@ARGV) {
  25
  26     open my $fh, "<", $fn or die "$fn: $!\n";
  27     my ($hdr, $body) = split m/(?<=\n)(?=\r?\n)/ => do { local $/; <$fh> }, 2;
  28     close $fh;
  29
  30     $hdr && $hdr =~ m/\b(?:Date|Received)\b/ or next;
  31
  32     my ($mid) = $hdr =~ m{^Message-Id:  (?:[\x20\t]*\n)?[\x20\t]+ (\S.*)}xmi;
  33     my ($dte) = $hdr =~ m{^Date:        (?:[\x20\t]*\n)?[\x20\t]+ (\S.*)}xmi;
  34     my ($rcv) = $hdr =~ m{\nReceived:   (?:[\x20\t]*\n)?[\x20\t]+ (\S.*(?:\n\s+.*)*+)}xi;
  35     my ($irt) = $hdr =~ m{^In-Reply-To: (?:[\x20\t]*\n)?[\x20\t]+ (\S.*)}xmi;
  36     my ($ref) = $hdr =~ m{^References:  (?:[\x20\t]*\n)?[\x20\t]+ (\S.*)}xmi;
  37
  38     $rcv ||= $dte;
  39     $rcv =~ s/[\s\r\n]+/ /g;
  40     $rcv =~ s/\s+$//;
  41     $rcv =~ s/.*;\s*//;
  42     $rcv =~ s/.* id \S+\s+//i;
  43     my $stamp = str2time ($rcv) or die $rcv;
  44     my $date = $stamp ? do {
  45         my @d = localtime $stamp;
  46         sprintf "%4d-%02d-%02d %02d:%02d:%02d", $d[5] + 1900, ++$d[4], @d[3,2,1,0];
  47         } : "-";
  48     #printf "%12s %-20s %s\n", $stamp // "-", $date, $rcv;
  49
  50     $f{$fn} = {
  51         msg_id  => $mid,
  52         refs    => $ref,
  53         irt     => $irt,
  54         date    => $dte,
  55         rcvd    => $rcv,
  56         stamp   => $stamp,
  57         sdate   => $date,
  58
  59         hdr     => $hdr,
  60         body    => $body,
  61         };
  62
  63     $p //= $fn;
  64     $stamp < $f{$p}{stamp} and $p = $fn;
  65     }
  66
  67 # All but the oldest will refer to the oldest as parent
  68
  69 $p or exit 0;
  70 my $pid = $f{$p}{msg_id} or die "Parent file $p has no Message-Id\n";
  71
  72 foreach my $fn (sort keys %f) {
  73
  74     $fn eq $p and next;
  75
  76     my $c = 0;
  77
  78     my $f = $f{$fn};
  79     if ($f->{refs}) {
  80         unless ($f->{refs} eq $pid) {
  81             $c++;
  82             $f->{hdr} =~ s{^(?=References:)}{References: $pid\nX-}mi;
  83             }
  84         }
  85     else {
  86         $c++;
  87         $f->{hdr} =~ s{^(?=Message-Id:)}{References: $pid\n}mi;
  88         }
  89     if ($f->{irt}) {
  90         unless ($f->{irt} eq $pid) {
  91             $c++;
  92             $f->{hdr} =~ s{^(?=In-Reply-To:)}{In-Reply-To: $pid\nX-}mi;
  93             }
  94         }
  95     else {
  96         $c++;
  97         $f->{hdr} =~ s{^(?=Message-Id:)}{In-Reply-To: $pid\n}mi;
  98         }
  99
 100     $c or next; # No changes required
 101
 102     unless ($f->{msg_id}) {
 103         warn "Child message $fn has no Message-Id, skipped\n";
 104         next;
 105         }
 106
 107     say "$f->{msg_id} => $pid";
 108
 109     my @t = stat $fn;
 110     open my $fh, ">", $fn or die "$fn: $!\n";
 111     print   $fh $f->{hdr}, $f->{body};
 112     close   $fh or die "$fn: $!\n";
 113     utime $t[8], $t[9], $fn;
 114     }
 115
 116 __END__
 117
 118 =head1 NAME
 119
 120 cm-reparent.pl - fix mail threading
 121
 122 =head1 SYNOPSIS
 123
 124  cm-reparent.pl ~/Mail/inbox/23 ~/Mail/inbox/45 ...
 125
 126 =head1 DESCRIPTION
 127
 128 This script should be called from within Claws-Mail as an action
 129
 130 Define an action as
 131
 132   Menu name:  Reparent (fix threading)
 133   Command:    cm-reparent.pl %F
 134
 135 Then select from the message list all files that should be re-parented
 136
 137 Then invoke the action
 138
 139 All but the oldest of those mails will be modified (if needed) to
 140 reflect that the oldest mail is the parent of all other mails by
 141 adding or altering the header lines C<In-Reply-To:> and C<References:>
 142
 143 Given 4 files A, B, C, and D like
 144
 145  File         Message-Id    Date
 146  A            123AC_12      2016-06-01 12:13:14
 147  B            aFFde2993     2016-06-01 13:14:15
 148  C            0000_1234     2016-06-02 10:18:04
 149  D            foo_bar_12    2016-06-03 04:00:00
 150
 151 The new tree will be like
 152
 153  A            123AC_12      2016-06-01 12:13:14
 154  +- B         aFFde2993     2016-06-01 13:14:15
 155  +- C         0000_1234     2016-06-02 10:18:04
 156  +- D         foo_bar_12    2016-06-03 04:00:00
 157
 158 and not like
 159
 160  A            123AC_12      2016-06-01 12:13:14
 161  +- B         aFFde2993     2016-06-01 13:14:15
 162     +- C      0000_1234     2016-06-02 10:18:04
 163        +- D   foo_bar_12    2016-06-03 04:00:00
 164
 165 Existing entries of C<References:> and C<In-Reply-To:> in the header
 166 of any of B, C, or D will be preserved as C<X-References:> or
 167 C<X-In-Reply-To:> respectively.
 168
 169 =head1 SEE ALSO
 170
 171 L<Date::Parse>, L<Claws Mail|http://www.claws-mail.org>
 172 cm-break.pl
 173
 174 =head1 AUTHOR
 175
 176 H.Merijn Brand <h.m.brand@xs4all.nl>
 177
 178 =head1 COPYRIGHT AND LICENSE
 179
 180  Copyright (C) 2016-2018 H.Merijn Brand.  All rights reserved.
 181
 182 This library is free software;  you can redistribute and/or modify it under
 183 the same terms as Perl itself.
 184 See the L<Artistic license|http://dev.perl.org/licenses/artistic.html>.
 185
 186 =cut