Commit | Line | Data |
---|---|---|
431fbb12 | 1 | #! /usr/bin/perl -W |
0bd5c08c | 2 | # |
431fbb12 TH |
3 | # checkmail Version 0.3 by Thomas Hochstein |
4 | # | |
5 | # This script tries to verify the deliverability of (a) mail address(es). | |
6 | # | |
7 | # Copyright (c) 2002-2010 Thomas Hochstein <thh@inter.net> | |
0bd5c08c | 8 | # |
431fbb12 TH |
9 | # It can be redistributed and/or modified under the same terms under |
10 | # which Perl itself is published. | |
11 | ||
12 | our $VERSION = "0.3"; | |
13 | ||
14 | ################################# Configuration ################################ | |
15 | # Please fill in a working configuration! | |
16 | my %config=( | |
17 | # value used for HELO/EHLO - a valid hostname you own | |
18 | helo => 'testhost.domain.example', | |
19 | # value used for MAIL FROM: - a valid address under your control | |
20 | from => 'mailtest@testhost.domain.example', | |
21 | # a syntactically valid "random" - reliably not existing - localpart | |
22 | rand => 'ZOq62fow1i' | |
23 | ); | |
24 | ||
25 | ################################### Modules #################################### | |
26 | use strict; | |
27 | use File::Basename; | |
0bd5c08c TH |
28 | use Getopt::Std; |
29 | use Net::DNS; | |
30 | use Net::SMTP; | |
31 | ||
431fbb12 TH |
32 | ################################# Main program ################################# |
33 | ||
34 | $Getopt::Std::STANDARD_HELP_VERSION = 1; | |
35 | my $myself = basename($0); | |
36 | ||
37 | # read commandline options | |
0bd5c08c | 38 | my %options; |
431fbb12 TH |
39 | getopts('Vhqlrf:m:', \%options); |
40 | ||
41 | # -V: display version | |
42 | if ($options{'V'}) { | |
43 | print "$myself v $VERSION\nCopyright (c) 2010 Thomas Hochstein <thh\@inter.net>\n"; | |
44 | print "This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself.\n"; | |
45 | exit(100); | |
46 | }; | |
47 | ||
48 | # -h: feed myself to perldoc | |
49 | if ($options{'h'}) { | |
50 | exec('perldoc', $0); | |
51 | exit(100); | |
52 | }; | |
53 | ||
54 | # display usage information if neither -f nor an address are present | |
55 | if (!$options{'f'} and !$ARGV[0]) { | |
56 | print "Usage: $myself [-hqlr] [-m <host>] <address>|-f <file>\n"; | |
57 | print "Options: -V display copyright and version\n"; | |
58 | print " -h show documentation\n"; | |
59 | print " -q quiet (no output, just exit with 0/1/2/3)\n"; | |
60 | print " -l extended logging\n"; | |
61 | print " -r test random address to verify verification\n"; | |
62 | print " -m <host> no DNS lookup, just test this host\n"; | |
63 | print " <address> mail address to check\n\n"; | |
64 | print " -f <file> parse file (one address per line)\n"; | |
65 | exit(100); | |
0bd5c08c TH |
66 | }; |
67 | ||
431fbb12 TH |
68 | # -f: open file and read addresses to @adresses |
69 | my @addresses; | |
0bd5c08c TH |
70 | if ($options{'f'}) { |
71 | if (-e $options{'f'}) { | |
431fbb12 | 72 | open FILE, "<$options{'f'}" or die("$myself ERROR: Could not open file $options{'f'} for reading: $!"); |
0bd5c08c | 73 | } else { |
431fbb12 | 74 | die("$myself ERROR: File $options{'f'} does not exist!\n"); |
0bd5c08c | 75 | }; |
0bd5c08c TH |
76 | while(<FILE>) { |
77 | chomp; | |
431fbb12 | 78 | push(@addresses,$_); |
0bd5c08c TH |
79 | }; |
80 | close FILE; | |
431fbb12 TH |
81 | # fill @adresses with single address to check |
82 | } else { | |
83 | push(@addresses,$ARGV[0]); | |
84 | }; | |
85 | ||
86 | # loop over each address and test it | |
87 | my (%targets,$curstat,$status,$log,$message); | |
88 | foreach (@addresses) { | |
89 | my $address = $_; | |
90 | (undef,my $domain) = splitaddress($address); | |
91 | printf(" * Testing %s ...\n",$address) if !($options{'q'}); | |
92 | $log .= "\n===== BEGIN $address =====\n"; | |
93 | # get list of target hosts or take host forced via -m | |
94 | if (!$options{'m'}) { | |
95 | %targets = %{gettargets($domain,\$log)}; | |
96 | } else { | |
97 | $message = sprintf("Connection to %s forced by -m.\n",$options{'m'}); | |
98 | $log .= $message; | |
99 | print " $message" if !($options{'q'}); | |
100 | # just one target host with preference 0 | |
101 | $targets{$options{'m'}} = 0; | |
102 | }; | |
103 | if (%targets) { | |
104 | $curstat = checkaddress($address,\%targets,\$log); | |
105 | } else { | |
106 | $curstat = 2; | |
107 | $message = 'DNS lookup failure'; | |
108 | printf(" > Address is INVALID (%s).\n",$message) if !($options{'q'}); | |
109 | $log .= $message . '.'; | |
110 | }; | |
111 | $log .= "====== END $address ======\n"; | |
112 | $status = $curstat if (!defined($status) or $curstat > $status); | |
0bd5c08c TH |
113 | }; |
114 | ||
115 | print $log if ($options{'l'}); | |
116 | ||
117 | # status 0: valid / batch processing | |
431fbb12 TH |
118 | # 1: connection failed or temporary failure |
119 | # 2: invalid | |
120 | # 3: cannot verify | |
121 | #D print "\n-> EXIT $status\n"; | |
0bd5c08c TH |
122 | exit($status); |
123 | ||
431fbb12 TH |
124 | ################################## gettargets ################################## |
125 | # get mail exchanger(s) or A record(s) for a domain | |
126 | # IN : $domain: domain to query the DNS for | |
127 | # OUT: \%targets: reference to a hash containing a list of target hosts | |
128 | sub gettargets { | |
129 | my ($domain,$logr) = @_; | |
130 | # resolver objekt | |
131 | my $resolver = Net::DNS::Resolver->new(udp_timeout => 15, tcp_timeout => 15); | |
0bd5c08c | 132 | |
431fbb12 TH |
133 | my %targets; |
134 | # get MX record(s) as a list sorted by preference | |
135 | if (my @mxrr = mx($resolver,$domain)) { | |
136 | print_dns_result($domain,'MX',scalar(@mxrr),undef,$logr); | |
137 | foreach my $rr (@mxrr) { | |
138 | $targets{$rr->exchange} = $rr->preference; | |
139 | $$logr .= sprintf("(%d) %s\n",$rr->preference,$rr->exchange); | |
140 | }; | |
141 | # no MX record found; log and try A record(s) | |
142 | } else { | |
143 | print_dns_result($domain,'MX',undef,$resolver->errorstring,$logr); | |
144 | print(" Falling back to A record ...\n") if !($options{'q'}); | |
145 | # get A record(s) | |
146 | if (my $query = $resolver->query($domain,'A','IN')) { | |
147 | print_dns_result($domain,'A',$query->header->ancount,undef,$logr); | |
148 | foreach my $rr ($query->answer) { | |
149 | $targets{$rr->address} = 0; | |
150 | $$logr .= sprintf("- %s\n",$rr->address); | |
151 | }; | |
152 | # no A record found either; log and fail | |
153 | } else { | |
154 | print_dns_result($domain,'A',undef,$resolver->errorstring,$logr); | |
155 | printf(" %s has neither MX nor A records - mail cannot be delivered.\n",$domain) if !($options{'q'}); | |
156 | }; | |
0bd5c08c | 157 | }; |
431fbb12 TH |
158 | return \%targets; |
159 | }; | |
160 | ||
161 | ################################# checkaddress ################################# | |
162 | # test address for deliverability | |
163 | # IN : $address: adress to be tested | |
164 | # \%targets: reference to a hash containing a list of MX hosts | |
165 | # \$log : reference to the log (to be printed out via -l) | |
166 | # OUT: --- | |
167 | # \$log will be changed | |
168 | sub checkaddress { | |
169 | my ($address,$targetsr,$logr) = @_; | |
170 | my %targets = %{$targetsr}; | |
171 | my $status; | |
172 | # walk %targets in order of preference | |
173 | foreach my $host (sort { $targets{$a} <=> $targets{$b} } keys %targets) { | |
174 | printf(" / Trying %s (%s) with %s\n",$host,$targets{$host} || 'A',$address) if !($options{'q'}); | |
175 | $$logr .= sprintf("%s:\n%s\n",$host,"-" x (length($host)+1)); | |
176 | $status = checksmtp($address,$host,$logr); | |
177 | last if ($status != 1); | |
0bd5c08c | 178 | }; |
431fbb12 | 179 | return $status; |
0bd5c08c TH |
180 | }; |
181 | ||
431fbb12 TH |
182 | ################################### checksmtp ################################## |
183 | # connect to a remote machine on port 25 and test deliverability of a mail | |
184 | # address by doing the SMTP dialog until RCPT TO stage | |
185 | # IN : $address: address to test | |
186 | # $target : target host | |
187 | # \$log : reference to the log (to be printed out via -l) | |
188 | # OUT: .........: reference to a hash containing a list of target hosts | |
189 | # \$log will be changed | |
0bd5c08c | 190 | sub checksmtp { |
431fbb12 TH |
191 | my ($address,$target,$logr) = @_; |
192 | my ($status); | |
193 | # start SMTP connection | |
194 | if (my $smtp = Net::SMTP->new($target,Hello => $config{'helo'},Timeout => 30)) { | |
195 | $$logr .= $smtp->banner; # Net::SMTP doesn't seem to support multiline greetings. | |
196 | $$logr .= "EHLO $config{'helo'}\n"; | |
197 | log_smtp_reply($logr,$smtp->code,$smtp->message); | |
198 | $smtp->mail($config{'from'}); | |
199 | $$logr .= "MAIL FROM:<$config{'from'}>\n"; | |
200 | log_smtp_reply($logr,$smtp->code,$smtp->message); | |
201 | # test address | |
202 | my ($success,$code,@message) = try_rcpt_to(\$smtp,$address,$logr); | |
203 | # connection failure? | |
204 | if ($success < 0) { | |
205 | $status = connection_failed(); | |
206 | # delivery attempt was successful? | |
207 | } elsif ($success) { | |
208 | # -r: try random address (which should be guaranteed to be invalid) | |
209 | if ($options{'r'}) { | |
210 | (undef,my $domain) = splitaddress($address); | |
211 | my ($success,$code,@message) = try_rcpt_to(\$smtp,$config{'rand'}.'@'.$domain,$logr); | |
212 | # connection failure? | |
213 | if ($success < 0) { | |
214 | $status = connection_failed(); | |
215 | # verification impossible? | |
216 | } elsif ($success) { | |
217 | $status = 3; | |
218 | print " > Address verificaton impossible. You'll have to send a test mail ...\n" if !($options{'q'}); | |
219 | } | |
220 | } | |
221 | # if -r is not set or status was not set to 3: valid address | |
222 | if (!defined($status)) { | |
223 | $status = 0; | |
224 | print " > Address is valid.\n" if !($options{'q'}); | |
0bd5c08c | 225 | }; |
431fbb12 TH |
226 | # delivery attempt failed? |
227 | } else { | |
228 | $status = 2; | |
229 | print " > Address is INVALID:\n" if !($options{'q'}); | |
230 | print ' ' . join(' ',@message) if !($options{'q'}); | |
231 | } | |
232 | # terminate SMTP connection | |
233 | $smtp->quit; | |
234 | $$logr .= "QUIT\n"; | |
235 | log_smtp_reply($logr,$smtp->code,$smtp->message); | |
0bd5c08c | 236 | } else { |
431fbb12 TH |
237 | # SMTP connection failed / timeout |
238 | $status = connection_failed(); | |
239 | $$logr .= "---Connection failure---\n"; | |
0bd5c08c | 240 | }; |
431fbb12 TH |
241 | return $status; |
242 | } | |
243 | ||
244 | ################################# splitaddress ################################# | |
245 | # split mail address into local and domain part | |
246 | # IN : $address: a mail address | |
247 | # OUT: $local : local part | |
248 | # $domain: domain part | |
249 | sub splitaddress { | |
250 | my($address)=@_; | |
251 | (my $lp = $address) =~ s/^([^@]+)@.*/$1/; | |
252 | (my $domain = $address) =~ s/[^@]+\@(\S*)$/$1/; | |
253 | return ($lp,$domain); | |
254 | }; | |
255 | ||
256 | ################################ parse_dns_reply ############################### | |
257 | # parse DNS response codes and return code and description | |
258 | # IN : $response: a DNS response code | |
259 | # OUT: "$response ($desciption)" | |
260 | sub parse_dns_reply { | |
261 | my($response)=@_; | |
262 | my %dnsrespcodes = (NOERROR => 'empty response', | |
263 | NXDOMAIN => 'non-existent domain', | |
264 | SERVFAIL => 'DNS server failure', | |
265 | REFUSED => 'DNS query refused', | |
266 | FORMERR => 'format error', | |
267 | NOTIMP => 'not implemented'); | |
268 | if(defined($dnsrespcodes{$response})) { | |
269 | return sprintf('%s (%s)',$response,$dnsrespcodes{$response}); | |
270 | } else { | |
271 | return $response; | |
272 | }; | |
273 | }; | |
274 | ||
275 | ############################### print_dns_result ############################### | |
276 | # print and log result of DNS query | |
277 | # IN : $domain: domain the DNS was queried for | |
278 | # $type : record type (MX, A, ...) | |
279 | # $count : number of records found | |
280 | # $error : DNS response code | |
281 | # \$log : reference to the log (to be printed out via -l) | |
282 | # OUT: --- | |
283 | # \$log will be changed | |
284 | sub print_dns_result { | |
285 | my ($domain,$type,$count,$error,$logr) = @_; | |
286 | if (defined($count)) { | |
287 | printf(" %d %s record(s) found for %s\n",$count,$type,$domain) if !($options{'q'}); | |
288 | $$logr .= sprintf("%s DNS record(s):\n",$type); | |
289 | } else { | |
290 | printf(" No %s records found for %s: %s\n",$type,$domain,parse_dns_reply($error)) if !($options{'q'}); | |
291 | $$logr .= sprintf("No %s records found: %s\n",$type,parse_dns_reply($error)); | |
292 | }; | |
293 | return; | |
0bd5c08c TH |
294 | }; |
295 | ||
431fbb12 TH |
296 | ################################## try_rcpt_to ################################# |
297 | # send RCPT TO and return replies | |
298 | # IN : \$smtp : a reference to an SMTP object | |
299 | # $recipient: a mail address | |
300 | # \$log : reference to the log (to be printed out via -l) | |
301 | # OUT: $success: true or false | |
302 | # $code : SMTP status code | |
303 | # $message: SMTP status message | |
304 | # \$log will be changed | |
305 | sub try_rcpt_to { | |
306 | my($smtpr,$recipient,$logr)=@_; | |
307 | $$logr .= sprintf("RCPT TO:<%s>\n",$recipient); | |
308 | my $success = $$smtpr->to($recipient); | |
309 | if ($$smtpr->code) { | |
310 | log_smtp_reply($logr,$$smtpr->code,$$smtpr->message); | |
311 | } else { | |
312 | $success = -1; | |
313 | $$logr .= "---Connection failure---\n"; | |
314 | }; | |
315 | return ($success,$$smtpr->code,$$smtpr->message); | |
316 | }; | |
317 | ||
318 | ################################ log_smtp_reply ################################ | |
319 | # log result of SMTP command | |
320 | # IN : \$log : reference to the log (to be printed out via -l) | |
321 | # $code : SMTP status code | |
322 | # @message : SMTP status message | |
323 | # OUT: --- | |
324 | # \$log will be changed | |
325 | sub log_smtp_reply { | |
326 | my($logr,$code,@message)=@_; | |
327 | $$logr .= sprintf('%s %s',$code,join('- ',@message)); | |
328 | return; | |
0bd5c08c TH |
329 | } |
330 | ||
431fbb12 TH |
331 | ############################## connection_failed ############################### |
332 | # print failure message and return status 1 | |
333 | # OUT: 1 | |
334 | sub connection_failed { | |
335 | print " > Connection failure.\n" if !($options{'q'}); | |
336 | return 1; | |
337 | } |