| 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}, '.'); |