tidying
[exim.git] / src / util / chunking_fixqueue_finalnewlines.pl
1 #!/usr/bin/env perl
2
3 use warnings;
4 use strict;
5 BEGIN { pop @INC if $INC[-1] eq '.' };
6
7 use Fcntl qw(:DEFAULT :flock :seek);
8 use File::Find;
9 use File::Spec;
10
11 use constant MIN_AGE => 60; # seconds
12 my $exim = exists $ENV{'EXIM_BINARY'} ? $ENV{'EXIM_BINARY'} : 'exim';
13
14 my %known_okay = map {$_=>1} qw( linux darwin freebsd );
15 unless (exists $known_okay{$^O}) {
16 warn "for ease, this perl uses flock, not fcntl, assuming they're the same\n";
17 warn "this is not known by this author to be the case on $^O\n";
18 warn "please investigate and either add to allowed-list in script, or rewrite\n";
19 die "bailing out";
20
21 # Another approach to rewriting script: stop all exim receivers and
22 # queue-runners, prevent them from starting, then add your OS to the list and
23 # run, even though the locking type is wrong, relying upon not actually
24 # contending.
25 }
26
27 my $spool_dir = `$exim -n -bP spool_directory`;
28 chomp $spool_dir;
29
30 chdir(File::Spec->catfile($spool_dir, 'input'))
31 or die "chdir($spool_dir/input) failed: $!\n";
32
33 my $exim_msgid_r = qr/(?:[0-9A-Za-z]{6}-[0-9A-Za-z]{6}-[0-9A-Za-z]{2})/;
34 my $spool_dfile_r = qr/^(($exim_msgid_r)-D)\z/o;
35
36 sub fh_ends_newline {
37 my ($fh, $dfn, $verbose) = @_;
38 seek($fh, -1, 2) or do { warn "seek(file($dfn)) failed: $!\n"; return -1 };
39 my $count = read $fh, my $ch, 1;
40 if ($count == -1) { warn "failed to read last byte of $dfn\n"; return -1 };
41 if ($count == 0) { warn "file shrunk by one?? problem with $dfn\n"; return -1 };
42 if ($ch eq "\n") { print "okay!\n" if $verbose; return 1 }
43 print "PROBLEM: $dfn missing final newline (got $ch)\n" if $verbose;
44 return 0;
45 }
46
47
48 sub each_found_file {
49 return unless $_ =~ $spool_dfile_r;
50 my ($msgid, $dfn) = ($2, $1);
51
52 # We should have already upgraded Exim before invoking us, thus any spool
53 # files will be old and we can reduce spending time trying to lock files
54 # still being written to, etc.
55 my @st = lstat($dfn) or return;
56 if ($^T - $st[9] < MIN_AGE) { return };
57 -f "./${msgid}-H" || return;
58
59 print "consider: $dfn\n";
60 open(my $fh, '+<:raw', $dfn) or do {
61 warn "open($dfn) failed: $!\n";
62 return;
63 };
64 # return with a lexical FH in modern Perl should guarantee close, AIUI
65
66 # we do our first check without a lock, so that we can scan past messages
67 # being handled by Exim quickly, and only lock up on those which Exim is
68 # trying and failing to deliver. However, since Exim will be hung on remote
69 # hosts, this is likely. Thus best to kill queue-runners first.
70
71 return if fh_ends_newline($fh, $dfn, 0); # also returns on error
72 print "Problem? $msgid probably missing newline, locking to be sure ...\n";
73 flock($fh, LOCK_EX) or do { warn "flock(file($dfn)) failed: $!\n"; return };
74 return if fh_ends_newline($fh, $dfn, 1); # also returns on error
75
76 fixup_message($msgid, $dfn, $fh);
77
78 close($fh) or warn "close($dfn) failed: $!\n";
79 };
80
81 sub fixup_message {
82 my ($msgid, $dfn, $fh) = @_;
83 # we can't freeze the message, our lock stops that, which is good!
84
85 seek($fh, 0, 2) or do { warn "seek(file($dfn)) failed: $!\n"; return -1 };
86
87 my $r = inc_message_header_linecount($msgid);
88 if ($r < 0) {
89 warn "failed to fix message headers in ${msgid}-H so not editing message\n";
90 return;
91 }
92
93 print {$fh} "\n";
94
95 print "${msgid}: added newline\n";
96 };
97
98 sub inc_message_header_linecount {
99 my ($msgid) = @_;
100 my $name_in = "${msgid}-H";
101 my $name_out = "${msgid}-chunkfix";
102
103 open(my $in, '<:perlio', $name_in) or do { warn "open(${name_in}) failed: $!\n"; return -1 };
104 open(my $out, '>:perlio', $name_out) or do { warn "write-open(${name_out}) failed: $!\n"; return -1 };
105 my $seen = 0;
106 my $lc;
107 foreach (<$in>) {
108 if ($seen) {
109 print {$out} $_;
110 next;
111 }
112 if (/^(-body_linecount\s+)(\d+)(\s*)$/) {
113 $lc = $2 + 1;
114 print {$out} "${1}${lc}${3}";
115 $seen = 1;
116 next;
117 }
118 print {$out} $_;
119 }
120 close($in) or do {
121 warn "read-close(${msgid}-H) failed, assuming incomplete: $!\n";
122 close($out);
123 unlink $name_out;
124 return -1;
125 };
126 close($out) or do {
127 warn "write-close(${msgid}-chunkfix) failed, aborting: $!\n";
128 unlink $name_out;
129 return -1;
130 };
131
132 my @target = stat($name_in) or do { warn "stat($name_in) failed: $!\n"; unlink $name_out; return -1 };
133 my @created = stat($name_out) or do { warn "stat($name_out) failed: $!\n"; unlink $name_out; return -1 };
134 # 4=uid, 5=gid, 2=mode
135 if (($created[5] != $target[5]) or ($created[4] != $target[4])) {
136 chown $target[4], $target[5], $name_out or do {
137 warn "chown($name_out) failed: $!\n";
138 unlink $name_out;
139 return -1;
140 };
141 }
142 if (($created[2]&07777) != ($target[2]&0x7777)) {
143 chmod $target[2]&0x7777, $name_out or do {
144 warn "chmod($name_out) failed: $!\n";
145 unlink $name_out;
146 return -1;
147 };
148 }
149
150 rename $name_out, $name_in or do {
151 warn "rename '${msgid}-chunkfix' -> '${msgid}-H' failed: $!\n";
152 unlink $name_out;
153 return -1;
154 };
155
156 print "${msgid}: linecount set to $lc\n";
157 return 1;
158 }
159
160 find({wanted => \&each_found_file}, '.');