| 1 | #! /usr/bin/perl -W |
| 2 | # |
| 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> |
| 8 | # |
| 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; |
| 28 | use Getopt::Std; |
| 29 | use Net::DNS; |
| 30 | use Net::SMTP; |
| 31 | |
| 32 | ################################# Main program ################################# |
| 33 | |
| 34 | $Getopt::Std::STANDARD_HELP_VERSION = 1; |
| 35 | my $myself = basename($0); |
| 36 | |
| 37 | # read commandline options |
| 38 | my %options; |
| 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); |
| 66 | }; |
| 67 | |
| 68 | # -f: open file and read addresses to @adresses |
| 69 | my @addresses; |
| 70 | if ($options{'f'}) { |
| 71 | if (-e $options{'f'}) { |
| 72 | open FILE, "<$options{'f'}" or die("$myself ERROR: Could not open file $options{'f'} for reading: $!"); |
| 73 | } else { |
| 74 | die("$myself ERROR: File $options{'f'} does not exist!\n"); |
| 75 | }; |
| 76 | while(<FILE>) { |
| 77 | chomp; |
| 78 | push(@addresses,$_); |
| 79 | }; |
| 80 | close FILE; |
| 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); |
| 113 | }; |
| 114 | |
| 115 | print $log if ($options{'l'}); |
| 116 | |
| 117 | # status 0: valid / batch processing |
| 118 | # 1: connection failed or temporary failure |
| 119 | # 2: invalid |
| 120 | # 3: cannot verify |
| 121 | #D print "\n-> EXIT $status\n"; |
| 122 | exit($status); |
| 123 | |
| 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); |
| 132 | |
| 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 | }; |
| 157 | }; |
| 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); |
| 178 | }; |
| 179 | return $status; |
| 180 | }; |
| 181 | |
| 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 |
| 190 | sub checksmtp { |
| 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'}); |
| 225 | }; |
| 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); |
| 236 | } else { |
| 237 | # SMTP connection failed / timeout |
| 238 | $status = connection_failed(); |
| 239 | $$logr .= "---Connection failure---\n"; |
| 240 | }; |
| 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; |
| 294 | }; |
| 295 | |
| 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; |
| 329 | } |
| 330 | |
| 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 | } |