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