3 # checkmail Version 0.3 by Thomas Hochstein
5 # This script tries to verify the deliverability of (a) mail address(es).
7 # Copyright (c) 2002-2010 Thomas Hochstein <thh@inter.net>
9 # It can be redistributed and/or modified under the same terms under
10 # which Perl itself is published.
14 ################################# Configuration ################################
15 # Please fill in a working configuration!
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
25 ################################### Modules ####################################
32 ################################# Main program #################################
34 $Getopt::Std::STANDARD_HELP_VERSION = 1;
35 my $myself = basename($0);
37 # read commandline options
39 getopts('Vhqlrf:m:', \%options);
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";
48 # -h: feed myself to perldoc
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";
68 # -f: open file and read addresses to @adresses
71 if (-e $options{'f'}) {
72 open FILE, "<$options{'f'}" or die("$myself ERROR: Could not open file $options{'f'} for reading: $!");
74 die("$myself ERROR: File $options{'f'} does not exist!\n");
81 # fill @adresses with single address to check
83 push(@addresses,$ARGV[0]);
86 # loop over each address and test it
87 my (%targets,$curstat,$status,$log,$message);
88 foreach (@addresses) {
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
95 %targets = %{gettargets($domain,\$log)};
97 $message = sprintf("Connection to %s forced by -m.\n",$options{'m'});
99 print " $message" if !($options{'q'});
100 # just one target host with preference 0
101 $targets{$options{'m'}} = 0;
104 $curstat = checkaddress($address,\%targets,\$log);
107 $message = 'DNS lookup failure';
108 printf(" > Address is INVALID (%s).\n",$message) if !($options{'q'});
109 $log .= $message . '.';
111 $log .= "====== END $address ======\n";
112 $status = $curstat if (!defined($status) or $curstat > $status);
115 print $log if ($options{'l'});
117 # status 0: valid / batch processing
118 # 1: connection failed or temporary failure
121 #D print "\n-> EXIT $status\n";
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
129 my ($domain,$logr) = @_;
131 my $resolver = Net::DNS::Resolver->new(udp_timeout => 15, tcp_timeout => 15);
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);
141 # no MX record found; log and try A record(s)
143 print_dns_result($domain,'MX',undef,$resolver->errorstring,$logr);
144 print(" Falling back to A record ...\n") if !($options{'q'});
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);
152 # no A record found either; log and fail
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'});
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)
167 # \$log will be changed
169 my ($address,$targetsr,$logr) = @_;
170 my %targets = %{$targetsr};
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);
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
191 my ($address,$target,$logr) = @_;
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);
202 my ($success,$code,@message) = try_rcpt_to(\$smtp,$address,$logr);
203 # connection failure?
205 $status = connection_failed();
206 # delivery attempt was successful?
208 # -r: try random address (which should be guaranteed to be invalid)
210 (undef,my $domain) = splitaddress($address);
211 my ($success,$code,@message) = try_rcpt_to(\$smtp,$config{'rand'}.'@'.$domain,$logr);
212 # connection failure?
214 $status = connection_failed();
215 # verification impossible?
218 print " > Address verificaton impossible. You'll have to send a test mail ...\n" if !($options{'q'});
221 # if -r is not set or status was not set to 3: valid address
222 if (!defined($status)) {
224 print " > Address is valid.\n" if !($options{'q'});
226 # delivery attempt failed?
229 print " > Address is INVALID:\n" if !($options{'q'});
230 print ' ' . join(' ',@message) if !($options{'q'});
232 # terminate SMTP connection
235 log_smtp_reply($logr,$smtp->code,$smtp->message);
237 # SMTP connection failed / timeout
238 $status = connection_failed();
239 $$logr .= "---Connection failure---\n";
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
251 (my $lp = $address) =~ s/^([^@]+)@.*/$1/;
252 (my $domain = $address) =~ s/[^@]+\@(\S*)$/$1/;
253 return ($lp,$domain);
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 {
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});
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)
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);
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));
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
306 my($smtpr,$recipient,$logr)=@_;
307 $$logr .= sprintf("RCPT TO:<%s>\n",$recipient);
308 my $success = $$smtpr->to($recipient);
310 log_smtp_reply($logr,$$smtpr->code,$$smtpr->message);
313 $$logr .= "---Connection failure---\n";
315 return ($success,$$smtpr->code,$$smtpr->message);
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
324 # \$log will be changed
326 my($logr,$code,@message)=@_;
327 $$logr .= sprintf('%s %s',$code,join('- ',@message));
331 ############################## connection_failed ###############################
332 # print failure message and return status 1
334 sub connection_failed {
335 print " > Connection failure.\n" if !($options{'q'});