Add new action script for fixing threads

Many thanks to H.Merijn Brand for contributing it!

diff --git a/tools/README b/tools/README
index 1d2bc57d6bf9bdf6c29574860e3f0f91fea092cc..f68ea6b5a9628be41db46f4fe984c9a3a0eb8219 100644 (file)
--- a/tools/README
+++ b/tools/README
@@ -12,6 +12,7 @@ Action scripts:
   uudec                         Decode and display uuencoded images
   uuooffice                     Decode uuencoded attachments and open them with
                                 OpenOffice
+  cm-reparent.pl                Fix thread parenting for two or more messages
 
 Addressbook conversion:
   csv2addressbook.pl           Import Becky, Thunderbird, Kmail, Gmail and Fox
@@ -89,6 +90,11 @@ Action scripts
   COMMAND: uuooffice %f&
   Decode uuencoded attachments and open them with OpenOffice
 
+* cm-reparent.pl
+  WORKS ON: selected messages (two or more)
+  COMMAND: cm-reparent.pl %F
+  Fix threading by setting old messages first on thread
+
 * More action examples can be found at the Claws Mail FAQ
   http://www.claws-mail.org/faq/index.php/Actions
 

diff --git a/tools/cm-reparent.pl b/tools/cm-reparent.pl
new file mode 100755 (executable)
index 0000000..46e2cdb
--- /dev/null
+++ b/tools/cm-reparent.pl
@@ -0,0 +1,138 @@
+#!/usr/bin/perl
+
+use 5.14.1;
+use warnings;
+
+our $VERSION = "1.02 - 2016-06-07";
+
+sub usage {
+    my $err = shift and select STDERR;
+    say "usage: $0 file ...";
+    exit $err;
+    } # usage
+
+use Date::Parse;
+use Getopt::Long;
+GetOptions (
+    "help|?"   => sub { usage (0); },
+    "V|version"        => sub { say $0 =~ s{.*/}{}r, " [$VERSION]"; exit 0; },
+    ) or usage (1);
+
+my $p;
+my %f;
+foreach my $fn (@ARGV) {
+
+    open my $fh, "<", $fn or die "$fn: $!\n";
+    my ($hdr, $body) = split m/(?<=\n)(?=\r?\n)/ => do { local $/; <$fh> }, 2;
+    close $fh;
+
+    $hdr or next;
+
+    my ($mid) = $hdr =~ m{^Message-Id: (.*)}mi;
+    my ($dte) = $hdr =~ m{^Date: (.*)}mi;
+    my ($irt) = $hdr =~ m{^In-Reply-To: (.*)}mi;
+    my ($ref) = $hdr =~ m{^References: (.*)}mi;
+
+    my $stamp = str2time ($dte) or next;
+
+    $f{$fn} = {
+       msg_id  => $mid,
+       refs    => $ref,
+       irt     => $irt,
+       date    => $dte,
+       stamp   => $stamp,
+
+       hdr     => $hdr,
+       body    => $body,
+       };
+
+    $p //= $fn;
+
+    $stamp < $f{$p}{stamp} and $p = $fn;
+    }
+
+# All but the oldest will refer to the oldest as parent
+
+$p or exit 0;
+my $pid = $f{$p}{msg_id};
+
+foreach my $fn (sort keys %f) {
+
+    $fn eq $p and next;
+
+    my $c = 0;
+
+    my $f = $f{$fn};
+    if ($f->{refs}) {
+       unless ($f->{refs} eq $pid) {
+           $c++;
+           $f->{hdr} =~ s{^(?=References:)}{References: $pid\nX-}mi;
+           }
+       }
+    else {
+       $c++;
+       $f->{hdr} =~ s{^(?=Message-Id:)}{References: $pid\n}mi;
+       }
+    if ($f->{irt}) {
+       unless ($f->{irt} eq $pid) {
+           $c++;
+           $f->{hdr} =~ s{^(?=In-Reply-To:)}{In-Reply-To: $pid\nX-}mi;
+           }
+       }
+    else {
+       $c++;
+       $f->{hdr} =~ s{^(?=Message-Id:)}{In-Reply-To: $pid\n}mi;
+       }
+
+    $c or next;        # No changes required
+
+    say "$f->{msg_id} => $pid";
+
+    open my $fh, ">", $fn or die "$fn: $!\n";
+    print $fh $f->{hdr}, $f->{body};
+    close $fh or die "$fn: $!\n";
+    }
+
+__END__
+
+=head1 NAME
+
+cm-reparent.pl - fix mail threading
+
+=head1 SYNOPSIS
+
+ cm-reparent.pl ~/Mail/inbox/23 ~/Mail/inbox/45 ...
+
+=head1 DESCRIPTION
+
+This script should be called from withing Claws-Mail as an action
+
+Define an action as
+
+  Menu name:  Reparent (fix threading)
+  Command:    cm-reparent.pl %F
+
+Then select from the list-view all files that should be re-parented
+
+Then invoke the action
+
+All but the oldest of those mails will be modified (if needed) to
+reflect that the oldest mail is the parent of all other mails
+
+=head1 SEE ALSO
+
+L<Date::Parse>, L<Claws Mail|http://www.claws-mail.org>
+
+=head1 AUTHOR
+
+H.Merijn Brand <h.m.brand@xs4all.nl>
+
+=head1 COPYRIGHT AND LICENSE
+
+ Copyright (C) 2016-2016 H.Merijn Brand.  All rights reserved.
+
+This library is free software;  you can redistribute and/or modify it under
+the same terms as Perl itself.
+See the L<Artistic license|http://dev.perl.org/licenses/artistic.html>.
+
+=cut