Commit | Line | Data |
---|---|---|
7dc5f827 PP |
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}, '.'); |