Update list of TLDs for release
[claws.git] / 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