1#!/usr/bin/perl
2
3use 5.14.1;
4use warnings;
5
6our $VERSION = "1.05 - 2018-10-08";
7our $cmd = $0 =~ s{.*/}{}r;
8
9sub usage {
10    my $err = shift and select STDERR;
11    say "usage: $cmd file ...";
12    exit $err;
13    } # usage
14
15use Date::Parse;
16use Getopt::Long;
17GetOptions (
18    "help|?"	=> sub { usage (0); },
19    "V|version"	=> sub { say "$cmd [$VERSION]"; exit 0; },
20    ) or usage (1);
21
22my $p;
23my %f;
24foreach 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;
70my $pid = $f{$p}{msg_id} or die "Parent file $p has no Message-Id\n";
71
72foreach 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
120cm-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
128This script should be called from within Claws-Mail as an action
129
130Define an action as
131
132  Menu name:  Reparent (fix threading)
133  Command:    cm-reparent.pl %F
134
135Then select from the message list all files that should be re-parented
136
137Then invoke the action
138
139All but the oldest of those mails will be modified (if needed) to
140reflect that the oldest mail is the parent of all other mails by
141adding or altering the header lines C<In-Reply-To:> and C<References:>
142
143Given 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
151The 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
158and 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
165Existing entries of C<References:> and C<In-Reply-To:> in the header
166of any of B, C, or D will be preserved as C<X-References:> or
167C<X-In-Reply-To:> respectively.
168
169=head1 SEE ALSO
170
171L<Date::Parse>, L<Claws Mail|http://www.claws-mail.org>
172cm-break.pl
173
174=head1 AUTHOR
175
176H.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
182This library is free software;  you can redistribute and/or modify it under
183the same terms as Perl itself.
184See the L<Artistic license|http://dev.perl.org/licenses/artistic.html>.
185
186=cut
187