[mail/checkmail.git] / checkmail.pl

#! /usr/bin/perl -W
#
# checkmail Version 0.3 by Thomas Hochstein
#
# This script tries to verify the deliverability of (a) mail address(es).
# 
# Copyright (c) 2002-2010 Thomas Hochstein <thh@inter.net>
#
# It can be redistributed and/or modified under the same terms under 
# which Perl itself is published.

our $VERSION = "0.3";

################################# Configuration ################################
# Please fill in a working configuration!
my %config=(
            # value used for HELO/EHLO - a valid hostname you own
            helo => 'testhost.domain.example',
            # value used for MAIL FROM: - a valid address under your control
            from => 'mailtest@testhost.domain.example'
           );

################################### Modules ####################################
use strict;
use File::Basename;
use Getopt::Std;
use Net::DNS;
use Net::SMTP;

################################# Main program #################################

$Getopt::Std::STANDARD_HELP_VERSION = 1;
my $myself = basename($0);

# read commandline options
my %options;
getopts('Vhqlrf:m:', \%options);

# -V: display version
if ($options{'V'}) {
  print "$myself v $VERSION\nCopyright (c) 2010 Thomas Hochstein <thh\@inter.net>\n";
  print "This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself.\n";
  exit(100);
};

# -h: feed myself to perldoc
if ($options{'h'}) {
  exec('perldoc', $0);
  exit(100);
};

# display usage information if neither -f nor an address are present
if (!$options{'f'} and !$ARGV[0]) {
  print "Usage: $myself [-hqlr] [-m <host>] <address>|-f <file>\n";
  print "Options: -V  display copyright and version\n";
  print "         -h  show documentation\n";
  print "         -q  quiet (no output, just exit with 0/1/2/3)\n";
  print "         -l  extended logging\n";
  print "         -r  test random address to verify verification\n";
  print "  -m <host>  no DNS lookup, just test this host\n";
  print "  <address>  mail address to check\n\n";
  print "  -f <file>  parse file (one address per line)\n";
  exit(100);
};

# -f: open file and read addresses to @adresses
my @addresses;
if ($options{'f'}) {
 if (-e $options{'f'}) {
  open FILE, "<$options{'f'}" or die("$myself ERROR: Could not open file $options{'f'} for reading: $!");
 } else {
  die("$myself ERROR: File $options{'f'} does not exist!\n");
 };
 while(<FILE>) {
  chomp;
  push(@addresses,$_);
 };
 close FILE;
# fill @adresses with single address to check
 } else {
  push(@addresses,$ARGV[0]);
};

# loop over each address and test it
my (%targets,$curstat,$status,$log,$message);
foreach (@addresses) {
  my $address = $_;
  (undef,my $domain) = splitaddress($address);
  printf("  * Testing %s ...\n",$address) if !($options{'q'});
  $log .=  "\n===== BEGIN $address =====\n";
  # get list of target hosts or take host forced via -m
  if (!$options{'m'}) {
	  %targets = %{gettargets($domain,\$log)};
  } else {
    $message = sprintf("Connection to %s forced by -m.\n",$options{'m'});
    $log .= $message;
    print "    $message" if !($options{'q'});
    # just one target host with preference 0
    $targets{$options{'m'}} = 0;
  };
  if (%targets) {
    $curstat = checkaddress($address,\%targets,\$log);
  } else {
    $curstat = 2;
    $message = 'DNS lookup failure';
    printf("  > Address is INVALID (%s).\n",$message) if !($options{'q'});
    $log .= $message . '.';
  };
  $log   .=  "====== END $address ======\n";
  $status = $curstat if (!defined($status) or $curstat > $status);
};

print $log if ($options{'l'});

# status 0: valid / batch processing
#        1: connection failed or temporary failure
#        2: invalid
#        3: cannot verify
#D print "\n-> EXIT $status\n";
exit($status);

################################## gettargets ##################################
# get mail exchanger(s) or A record(s) for a domain
# IN : $domain: domain to query the DNS for
# OUT: \%targets: reference to a hash containing a list of target hosts
sub gettargets {
  my ($domain,$logr) = @_;
  # resolver objekt
  my $resolver = Net::DNS::Resolver->new(udp_timeout => 15, tcp_timeout => 15);

  my %targets;
  # get MX record(s) as a list sorted by preference
  if (my @mxrr = mx($resolver,$domain)) {
    print_dns_result($domain,'MX',scalar(@mxrr),undef,$logr);
    foreach my $rr (@mxrr) {
	 $targets{$rr->exchange} = $rr->preference;
	 $$logr .= sprintf("(%d) %s\n",$rr->preference,$rr->exchange);
    };
  # no MX record found; log and try A record(s)
  } else {
    print_dns_result($domain,'MX',undef,$resolver->errorstring,$logr);
    print("    Falling back to A record ...\n") if !($options{'q'});
	# get A record(s)
    if (my $query = $resolver->query($domain,'A','IN')) {
      print_dns_result($domain,'A',$query->header->ancount,undef,$logr);
      foreach my $rr ($query->answer) {
        $targets{$rr->address} = 0;
        $$logr .= sprintf("- %s\n",$rr->address);
      };
    # no A record found either; log and fail
    } else {
      print_dns_result($domain,'A',undef,$resolver->errorstring,$logr);
      printf("    %s has neither MX nor A records - mail cannot be delivered.\n",$domain) if !($options{'q'});
    };
  };
  return \%targets;
};

################################# checkaddress #################################
# test address for deliverability
# IN : $address: adress to be tested
#      \%targets: reference to a hash containing a list of MX hosts
#      \$log    : reference to the log (to be printed out via -l)
# OUT: ---
#      \$log will be changed
sub checkaddress {
  my ($address,$targetsr,$logr) = @_;
  my %targets = %{$targetsr};
  my $status;
  # walk %targets in order of preference
  foreach my $host (sort { $targets{$a} <=> $targets{$b} } keys %targets) {
    printf("  / Trying %s (%s) with %s\n",$host,$targets{$host} || 'A',$address) if !($options{'q'});
	  $$logr .= sprintf("%s:\n%s\n",$host,"-" x (length($host)+1));
	  $status = checksmtp($address,$host,$logr);
	  last if ($status != 1);
  };
  return $status;
};

################################### checksmtp ##################################
# connect to a remote machine on port 25 and test deliverability of a mail
# address by doing the SMTP dialog until RCPT TO stage
# IN : $address: address to test
#      $target : target host
#      \$log    : reference to the log (to be printed out via -l)
# OUT: .........: reference to a hash containing a list of target hosts
#      \$log will be changed
sub checksmtp {
  my ($address,$target,$logr) = @_;
  my ($status);
  # start SMTP connection
  if (my $smtp = Net::SMTP->new($target,Hello => $config{'helo'},Timeout => 30)) {
    $$logr .= $smtp->banner; # Net::SMTP doesn't seem to support multiline greetings.
    $$logr .= "EHLO $config{'helo'}\n";
    log_smtp_reply($logr,$smtp->code,$smtp->message);
    $smtp->mail($config{'from'});
    $$logr .= "MAIL FROM:<$config{'from'}>\n";
    log_smtp_reply($logr,$smtp->code,$smtp->message);
    # test address
    my ($success,$code,@message) = try_rcpt_to(\$smtp,$address,$logr);
    # connection failure?
    if ($success < 0) {
      $status = connection_failed(@message);
    # delivery attempt was successful?
    } elsif ($success) {
      # -r: try random address (which should be guaranteed to be invalid)
      if ($options{'r'}) {
        (undef,my $domain) = splitaddress($address);
        my ($success,$code,@message) = try_rcpt_to(\$smtp,create_rand_addr($domain),$logr);
        # connection failure?
        if ($success < 0) {
          $status = connection_failed(@message);
        # verification impossible?
        } elsif ($success) {
          $status = 3;
          print "  > Address verificaton impossible. You'll have to send a test mail ...\n" if !($options{'q'});
        }
      }
      # if -r is not set or status was not set to 3: valid address
      if (!defined($status)) {
        $status = 0;
        print "  > Address is valid.\n" if !($options{'q'});
      };
    # delivery attempt failed?
    } else {
      $status = 2;
      print "  > Address is INVALID:\n" if !($options{'q'});
      print '    ' . join('    ',@message) if !($options{'q'});
    }
    # terminate SMTP connection
    $smtp->quit;
    $$logr .= "QUIT\n";
    log_smtp_reply($logr,$smtp->code,$smtp->message);
  } else {
    # SMTP connection failed / timeout
    $status = connection_failed();
    $$logr .= "---Connection failure---\n";
  };
  return $status;
}

################################# splitaddress #################################
# split mail address into local and domain part
# IN : $address: a mail address
# OUT: $local : local part
#      $domain: domain part
sub splitaddress {
  my($address)=@_;
  (my $lp = $address) =~ s/^([^@]+)@.*/$1/;
  (my $domain = $address) =~ s/[^@]+\@(\S*)$/$1/;
  return ($lp,$domain);
};

############################### create_rand_addr ###############################
# create a random mail address
# IN : $domain: the domain part
# OUT: $address: the address
sub create_rand_addr {
  my($domain)=@_;
  my $allowed = 'ABCDEFGHJKLMNPQRSTUVWXYZabcdefghjkmnpqrstuvwxyz23456789-+_=';
  my $address = '';
  while (length($address) < 15) { 
    $address .= substr($allowed, (int(rand(length($allowed)))),1);
  };
  return ($address.'@'.$domain);
};

################################ parse_dns_reply ###############################
# parse DNS response codes and return code and description
# IN : $response: a DNS response code
# OUT: "$response ($desciption)"
sub parse_dns_reply {
  my($response)=@_;
  my %dnsrespcodes = (NOERROR  => 'empty response',
                      NXDOMAIN => 'non-existent domain',
                      SERVFAIL => 'DNS server failure',
                      REFUSED  => 'DNS query refused',
                      FORMERR  => 'format error',
                      NOTIMP   => 'not implemented');
  if(defined($dnsrespcodes{$response})) {
    return sprintf('%s (%s)',$response,$dnsrespcodes{$response});
  } else {
    return $response;
  };
};

############################### print_dns_result ###############################
# print and log result of DNS query
# IN : $domain: domain the DNS was queried for
#      $type  : record type (MX, A, ...)
#      $count : number of records found
#      $error : DNS response code
#      \$log : reference to the log (to be printed out via -l)
# OUT: ---
#      \$log will be changed
sub print_dns_result {
  my ($domain,$type,$count,$error,$logr) = @_;
  if (defined($count)) {
    printf("    %d %s record(s) found for %s\n",$count,$type,$domain) if !($options{'q'});
    $$logr .= sprintf("%s DNS record(s):\n",$type);
  } else {
    printf("    No %s records found for %s: %s\n",$type,$domain,parse_dns_reply($error)) if !($options{'q'});
    $$logr .= sprintf("No %s records found: %s\n",$type,parse_dns_reply($error));
  };
  return;
};

################################## try_rcpt_to #################################
# send RCPT TO and return replies
# IN : \$smtp    : a reference to an SMTP object
#      $recipient: a mail address
#      \$log     : reference to the log (to be printed out via -l)
# OUT: $success: exit code (0 for false, 1 for true, -1 for tempfail)
#      $code   : SMTP status code
#      $message: SMTP status message
#      \$log will be changed
sub try_rcpt_to {
  my($smtpr,$recipient,$logr)=@_;
  $$logr .= sprintf("RCPT TO:<%s>\n",$recipient);
  my $success;
  $$smtpr->to($recipient);
  if ($$smtpr->code) {
    log_smtp_reply($logr,$$smtpr->code,$$smtpr->message);
    $success = analyze_smtp_reply($$smtpr->code,$$smtpr->message);
  } else {
    $success = -1;
    $$logr .= "---Connection failure---\n";
  };
  return ($success,$$smtpr->code,$$smtpr->message);
};

################################ log_smtp_reply ################################
# log result of SMTP command
# IN : \$log    : reference to the log (to be printed out via -l)
#      $code    : SMTP status code
#      @message : SMTP status message
# OUT: ---
#      \$log will be changed
sub log_smtp_reply {
  my($logr,$code,@message)=@_;
  $$logr .= sprintf('%s %s',$code,join('- ',@message));
  return;
}

############################### analyze_smtp_reply ##############################
# analyze SMTP response codes and messages
# IN : $code    : SMTP status code
#      @message : SMTP status message
# OUT: exit code (0 for false, 1 for true, -1 for tempfail)
sub analyze_smtp_reply {
  my($code,@message)=@_;
  my $type = substr($code, 0, 1);
  if ($type == 2) {
    return 1;
  } elsif ($type == 5) {
    return 0;
  } elsif ($type == 4) {
    return -1;
  };
  return -1;
}

############################## connection_failed ###############################
# print failure message and return status 1
# IN : @message : SMTP status message
# OUT: 1
sub connection_failed {
  my(@message)=@_;
  print "  ! Connection failed or other temporary failure.\n" if !($options{'q'});
  printf("    %s\n",join('    ',@message)) if @message;
  return 1;
}

__END__

################################ Documentation #################################

=head1 NAME

checkmail - check deliverability of a mail address

=head1 SYNOPSIS

B<checkmail> [B<-Vhqlr>] [B<-m> I<host>] I<address>|B<-f> I<file>

=head1 REQUIREMENTS

=over 2

=item -

Perl 5.8 or later

=item -

File::Basename

=item -

Getopt::Std

=item -

Net::DNS I<(CPAN)>

=item -

Net::SMTP

=back

Furthermore you'll need a working DNS installation.

=head1 DESCRIPTION

checkmail checks the vailidity / deliverability of a mail address.
You may submit just one address as the last argument or a file
containing one address on each line using the B<-f> option.

=head2 Configuration

For the time being, all configuration is done in the script. You have
to set the following elements of the %config hash:

=over 4

=item B<$config{'helo'}>

The hostname to be used for I<HELO> or I<EHLO> in the SMTP dialog.

=item B<$config{'from'}>

The sender address to be used for I<MAIL FROM> while testing.

=back

=head2 Usage

After configuring the script you may run your first test with

    checkmail user@example.org

B<checkmail> will try to determine the mail exchanger(s) (MX)
responsible for I<example.org> by querying the DNS for the respective
MX records and then try to connect via SMTP (on port 25) to each of
them in order of precedence (if necessary). It will run through the
SMTP dialog until just before the I<DATA> stage, i.e. doing I<EHLO>,
I<MAIL FROM> and I<RCPT TO>. If no MX is defined, B<checkmail> will
fall back to the I<example.org> host itself, provided there is at
least one A record defined in the DNS. If there are neither MX nor A
records for I<example.org>, mail is not deliverable and B<checkmail>
will fail accordingly. If no host can be reached, B<checkmail> will
fail, too. Finally B<checkmail> will fail if mail to the given
recipient is not accepted by the respective host.

If B<checkmail> fails, you'll not be able to deliver mail to that
address - at least not using the configured sender address and from
the host you're testing from. However, the opposite is not true: a
mail you send may still not be delivered even if a test via
B<checkmail> succeeds. The receiving entity may reject your mail after
the I<DATA> stage, due to content checking or without any special
reason, or it may even drop, filter or bounce your mail after finally
accepting it. There is no way to be sure a mail will be accepted short
of sending a real mail to the address in question.

You may, however, try to detect hosts that will happily accept any and
all recipient in the SMTP dialog and just reject your mail later on,
for example to defeat exactly the kind of check you try to do.
B<checkmail> will do that by submitting a recipient address that is
known to be invalid; if that address is accepted, too, you'll know
that you can't reliably check the validity of any address on that
host. You can force that check by using the B<-r> option.

If you don't want to see just the results of your test, you can get a
B<complete log> of the SMTP dialog by using the B<-l> option. That may be
helpful to test for temporary failure conditions.

On the other hand you may use the B<-q> option to suppress all output;
B<checkmail> will then terminate with one of the following B<exit
status>:
       
=over 4

=item B<0>

address(es) seem/seems to be valid

=item B<1>

temporary error (connection failure or temporary failure)

=item B<2>

address is invalid

=item B<3>

address cannot reliably be checked (test using B<-r> failed)

=back

You can do B<batch processing> using B<-f> and submitting a file with
one address on each line. In that case the exit status is set to the
highest value generated by testing all addresses, i.e. it is set to
B<0> if and only if no adress failed, but to B<2> if even one address
failed and to B<3> if even one addresses couldn't reliably be checked.

And finally you can B<suppress DNS lookups> for MX and A records and
just force B<checkmail> to connect to a particular host using the
B<-m> option.

B<Please note:> You shouldn't try to validate addresses while working
from a dial-up or blacklisted host. If in doubt, use the B<-l> option
to have a closer look on the SMTP dialog yourself.

=head1 OPTIONS

=over 3

=item B<-V> (version)

Print out version and copyright information on B<checkmail> and exit.

=item B<-h> (help)

Print this man page and exit.

=item B<-q> (quit)

Suppress output and just terminate with a specific exit status.

=item B<-l> (log)

Log and print out the whole SMTP dialog.

=item B<-r> (random address)

Also try a reliably invalid address to catch hosts that try undermine
address verification.

=item B<-m> I<host> (MX to use)

Force a connection to I<host> to check deliverability to that
particular host irrespective of DNS entries. For example:

    checkmail -m test.host.example user@domain.example

=item B<-f> I<file> (file)

Process all addresses from I<file> (one on each line).

=back

=head1 INSTALLATION

Just copy checkmail to some directory and get started.

You can run your first test with

    checkmail user@example.org

=head1 ENVIRONMENT

See documentation of I<Net::DNS::Resolver>.

=head1 FILES

=over 4

=item F<checkmail.pl>

The script itself.

=back

=head1 BUGS

Please report any bugs or feature request to the author or use the
bug tracker at L<http://bugs.th-h.de/>!

=head1 SEE ALSO

L<http://th-h.de/download/scripts.php> will have the current
version of this program.

This program is maintained using the Git version control system. You
may clone L<git://code.th-h.de/mail/checkmail.git> to check out the
current development tree or browse it on the web via
L<http://code.th-h.de/?p=mail/checkmail.git>.

=head1 AUTHOR

Thomas Hochstein <thh@inter.net>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2002-2010 Thomas Hochstein <thh@inter.net>

This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.

=cut
Commit	Line	Data
	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	);
	22
	23	################################### Modules ####################################
	24	use strict;
	25	use File::Basename;
	26	use Getopt::Std;
	27	use Net::DNS;
	28	use Net::SMTP;
	29
	30	################################# Main program #################################
	31
	32	$Getopt::Std::STANDARD_HELP_VERSION = 1;
	33	my $myself = basename($0);
	34
	35	# read commandline options
	36	my %options;
	37	getopts('Vhqlrf:m:', \%options);
	38
	39	# -V: display version
	40	if ($options{'V'}) {
	41	print "$myself v $VERSION\nCopyright (c) 2010 Thomas Hochstein <thh\@inter.net>\n";
	42	print "This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself.\n";
	43	exit(100);
	44	};
	45
	46	# -h: feed myself to perldoc
	47	if ($options{'h'}) {
	48	exec('perldoc', $0);
	49	exit(100);
	50	};
	51
	52	# display usage information if neither -f nor an address are present
	53	if (!$options{'f'} and !$ARGV[0]) {
	54	print "Usage: $myself [-hqlr] [-m <host>] <address>\|-f <file>\n";
	55	print "Options: -V display copyright and version\n";
	56	print " -h show documentation\n";
	57	print " -q quiet (no output, just exit with 0/1/2/3)\n";
	58	print " -l extended logging\n";
	59	print " -r test random address to verify verification\n";
	60	print " -m <host> no DNS lookup, just test this host\n";
	61	print " <address> mail address to check\n\n";
	62	print " -f <file> parse file (one address per line)\n";
	63	exit(100);
	64	};
	65
	66	# -f: open file and read addresses to @adresses
	67	my @addresses;
	68	if ($options{'f'}) {
	69	if (-e $options{'f'}) {
	70	open FILE, "<$options{'f'}" or die("$myself ERROR: Could not open file $options{'f'} for reading: $!");
	71	} else {
	72	die("$myself ERROR: File $options{'f'} does not exist!\n");
	73	};
	74	while(<FILE>) {
	75	chomp;
	76	push(@addresses,$_);
	77	};
	78	close FILE;
	79	# fill @adresses with single address to check
	80	} else {
	81	push(@addresses,$ARGV[0]);
	82	};
	83
	84	# loop over each address and test it
	85	my (%targets,$curstat,$status,$log,$message);
	86	foreach (@addresses) {
	87	my $address = $_;
	88	(undef,my $domain) = splitaddress($address);
	89	printf(" * Testing %s ...\n",$address) if !($options{'q'});
	90	$log .= "\n===== BEGIN $address =====\n";
	91	# get list of target hosts or take host forced via -m
	92	if (!$options{'m'}) {
	93	%targets = %{gettargets($domain,\$log)};
	94	} else {
	95	$message = sprintf("Connection to %s forced by -m.\n",$options{'m'});
	96	$log .= $message;
	97	print " $message" if !($options{'q'});
	98	# just one target host with preference 0
	99	$targets{$options{'m'}} = 0;
	100	};
	101	if (%targets) {
	102	$curstat = checkaddress($address,\%targets,\$log);
	103	} else {
	104	$curstat = 2;
	105	$message = 'DNS lookup failure';
	106	printf(" > Address is INVALID (%s).\n",$message) if !($options{'q'});
	107	$log .= $message . '.';
	108	};
	109	$log .= "====== END $address ======\n";
	110	$status = $curstat if (!defined($status) or $curstat > $status);
	111	};
	112
	113	print $log if ($options{'l'});
	114
	115	# status 0: valid / batch processing
	116	# 1: connection failed or temporary failure
	117	# 2: invalid
	118	# 3: cannot verify
	119	#D print "\n-> EXIT $status\n";
	120	exit($status);
	121
	122	################################## gettargets ##################################
	123	# get mail exchanger(s) or A record(s) for a domain
	124	# IN : $domain: domain to query the DNS for
	125	# OUT: \%targets: reference to a hash containing a list of target hosts
	126	sub gettargets {
	127	my ($domain,$logr) = @_;
	128	# resolver objekt
	129	my $resolver = Net::DNS::Resolver->new(udp_timeout => 15, tcp_timeout => 15);
	130
	131	my %targets;
	132	# get MX record(s) as a list sorted by preference
	133	if (my @mxrr = mx($resolver,$domain)) {
	134	print_dns_result($domain,'MX',scalar(@mxrr),undef,$logr);
	135	foreach my $rr (@mxrr) {
	136	$targets{$rr->exchange} = $rr->preference;
	137	$$logr .= sprintf("(%d) %s\n",$rr->preference,$rr->exchange);
	138	};
	139	# no MX record found; log and try A record(s)
	140	} else {
	141	print_dns_result($domain,'MX',undef,$resolver->errorstring,$logr);
	142	print(" Falling back to A record ...\n") if !($options{'q'});
	143	# get A record(s)
	144	if (my $query = $resolver->query($domain,'A','IN')) {
	145	print_dns_result($domain,'A',$query->header->ancount,undef,$logr);
	146	foreach my $rr ($query->answer) {
	147	$targets{$rr->address} = 0;
	148	$$logr .= sprintf("- %s\n",$rr->address);
	149	};
	150	# no A record found either; log and fail
	151	} else {
	152	print_dns_result($domain,'A',undef,$resolver->errorstring,$logr);
	153	printf(" %s has neither MX nor A records - mail cannot be delivered.\n",$domain) if !($options{'q'});
	154	};
	155	};
	156	return \%targets;
	157	};
	158
	159	################################# checkaddress #################################
	160	# test address for deliverability
	161	# IN : $address: adress to be tested
	162	# \%targets: reference to a hash containing a list of MX hosts
	163	# \$log : reference to the log (to be printed out via -l)
	164	# OUT: ---
	165	# \$log will be changed
	166	sub checkaddress {
	167	my ($address,$targetsr,$logr) = @_;
	168	my %targets = %{$targetsr};
	169	my $status;
	170	# walk %targets in order of preference
	171	foreach my $host (sort { $targets{$a} <=> $targets{$b} } keys %targets) {
	172	printf(" / Trying %s (%s) with %s\n",$host,$targets{$host} \|\| 'A',$address) if !($options{'q'});
	173	$$logr .= sprintf("%s:\n%s\n",$host,"-" x (length($host)+1));
	174	$status = checksmtp($address,$host,$logr);
	175	last if ($status != 1);
	176	};
	177	return $status;
	178	};
	179
	180	################################### checksmtp ##################################
	181	# connect to a remote machine on port 25 and test deliverability of a mail
	182	# address by doing the SMTP dialog until RCPT TO stage
	183	# IN : $address: address to test
	184	# $target : target host
	185	# \$log : reference to the log (to be printed out via -l)
	186	# OUT: .........: reference to a hash containing a list of target hosts
	187	# \$log will be changed
	188	sub checksmtp {
	189	my ($address,$target,$logr) = @_;
	190	my ($status);
	191	# start SMTP connection
	192	if (my $smtp = Net::SMTP->new($target,Hello => $config{'helo'},Timeout => 30)) {
	193	$$logr .= $smtp->banner; # Net::SMTP doesn't seem to support multiline greetings.
	194	$$logr .= "EHLO $config{'helo'}\n";
	195	log_smtp_reply($logr,$smtp->code,$smtp->message);
	196	$smtp->mail($config{'from'});
	197	$$logr .= "MAIL FROM:<$config{'from'}>\n";
	198	log_smtp_reply($logr,$smtp->code,$smtp->message);
	199	# test address
	200	my ($success,$code,@message) = try_rcpt_to(\$smtp,$address,$logr);
	201	# connection failure?
	202	if ($success < 0) {
	203	$status = connection_failed(@message);
	204	# delivery attempt was successful?
	205	} elsif ($success) {
	206	# -r: try random address (which should be guaranteed to be invalid)
	207	if ($options{'r'}) {
	208	(undef,my $domain) = splitaddress($address);
	209	my ($success,$code,@message) = try_rcpt_to(\$smtp,create_rand_addr($domain),$logr);
	210	# connection failure?
	211	if ($success < 0) {
	212	$status = connection_failed(@message);
	213	# verification impossible?
	214	} elsif ($success) {
	215	$status = 3;
	216	print " > Address verificaton impossible. You'll have to send a test mail ...\n" if !($options{'q'});
	217	}
	218	}
	219	# if -r is not set or status was not set to 3: valid address
	220	if (!defined($status)) {
	221	$status = 0;
	222	print " > Address is valid.\n" if !($options{'q'});
	223	};
	224	# delivery attempt failed?
	225	} else {
	226	$status = 2;
	227	print " > Address is INVALID:\n" if !($options{'q'});
	228	print ' ' . join(' ',@message) if !($options{'q'});
	229	}
	230	# terminate SMTP connection
	231	$smtp->quit;
	232	$$logr .= "QUIT\n";
	233	log_smtp_reply($logr,$smtp->code,$smtp->message);
	234	} else {
	235	# SMTP connection failed / timeout
	236	$status = connection_failed();
	237	$$logr .= "---Connection failure---\n";
	238	};
	239	return $status;
	240	}
	241
	242	################################# splitaddress #################################
	243	# split mail address into local and domain part
	244	# IN : $address: a mail address
	245	# OUT: $local : local part
	246	# $domain: domain part
	247	sub splitaddress {
	248	my($address)=@_;
	249	(my $lp = $address) =~ s/^([^@]+)@.*/$1/;
	250	(my $domain = $address) =~ s/[^@]+\@(\S*)$/$1/;
	251	return ($lp,$domain);
	252	};
	253
	254	############################### create_rand_addr ###############################
	255	# create a random mail address
	256	# IN : $domain: the domain part
	257	# OUT: $address: the address
	258	sub create_rand_addr {
	259	my($domain)=@_;
	260	my $allowed = 'ABCDEFGHJKLMNPQRSTUVWXYZabcdefghjkmnpqrstuvwxyz23456789-+_=';
	261	my $address = '';
	262	while (length($address) < 15) {
	263	$address .= substr($allowed, (int(rand(length($allowed)))),1);
	264	};
	265	return ($address.'@'.$domain);
	266	};
	267
	268	################################ parse_dns_reply ###############################
	269	# parse DNS response codes and return code and description
	270	# IN : $response: a DNS response code
	271	# OUT: "$response ($desciption)"
	272	sub parse_dns_reply {
	273	my($response)=@_;
	274	my %dnsrespcodes = (NOERROR => 'empty response',
	275	NXDOMAIN => 'non-existent domain',
	276	SERVFAIL => 'DNS server failure',
	277	REFUSED => 'DNS query refused',
	278	FORMERR => 'format error',
	279	NOTIMP => 'not implemented');
	280	if(defined($dnsrespcodes{$response})) {
	281	return sprintf('%s (%s)',$response,$dnsrespcodes{$response});
	282	} else {
	283	return $response;
	284	};
	285	};
	286
	287	############################### print_dns_result ###############################
	288	# print and log result of DNS query
	289	# IN : $domain: domain the DNS was queried for
	290	# $type : record type (MX, A, ...)
	291	# $count : number of records found
	292	# $error : DNS response code
	293	# \$log : reference to the log (to be printed out via -l)
	294	# OUT: ---
	295	# \$log will be changed
	296	sub print_dns_result {
	297	my ($domain,$type,$count,$error,$logr) = @_;
	298	if (defined($count)) {
	299	printf(" %d %s record(s) found for %s\n",$count,$type,$domain) if !($options{'q'});
	300	$$logr .= sprintf("%s DNS record(s):\n",$type);
	301	} else {
	302	printf(" No %s records found for %s: %s\n",$type,$domain,parse_dns_reply($error)) if !($options{'q'});
	303	$$logr .= sprintf("No %s records found: %s\n",$type,parse_dns_reply($error));
	304	};
	305	return;
	306	};
	307
	308	################################## try_rcpt_to #################################
	309	# send RCPT TO and return replies
	310	# IN : \$smtp : a reference to an SMTP object
	311	# $recipient: a mail address
	312	# \$log : reference to the log (to be printed out via -l)
	313	# OUT: $success: exit code (0 for false, 1 for true, -1 for tempfail)
	314	# $code : SMTP status code
	315	# $message: SMTP status message
	316	# \$log will be changed
	317	sub try_rcpt_to {
	318	my($smtpr,$recipient,$logr)=@_;
	319	$$logr .= sprintf("RCPT TO:<%s>\n",$recipient);
	320	my $success;
	321	$$smtpr->to($recipient);
	322	if ($$smtpr->code) {
	323	log_smtp_reply($logr,$$smtpr->code,$$smtpr->message);
	324	$success = analyze_smtp_reply($$smtpr->code,$$smtpr->message);
	325	} else {
	326	$success = -1;
	327	$$logr .= "---Connection failure---\n";
	328	};
	329	return ($success,$$smtpr->code,$$smtpr->message);
	330	};
	331
	332	################################ log_smtp_reply ################################
	333	# log result of SMTP command
	334	# IN : \$log : reference to the log (to be printed out via -l)
	335	# $code : SMTP status code
	336	# @message : SMTP status message
	337	# OUT: ---
	338	# \$log will be changed
	339	sub log_smtp_reply {
	340	my($logr,$code,@message)=@_;
	341	$$logr .= sprintf('%s %s',$code,join('- ',@message));
	342	return;
	343	}
	344
	345	############################### analyze_smtp_reply ##############################
	346	# analyze SMTP response codes and messages
	347	# IN : $code : SMTP status code
	348	# @message : SMTP status message
	349	# OUT: exit code (0 for false, 1 for true, -1 for tempfail)
	350	sub analyze_smtp_reply {
	351	my($code,@message)=@_;
	352	my $type = substr($code, 0, 1);
	353	if ($type == 2) {
	354	return 1;
	355	} elsif ($type == 5) {
	356	return 0;
	357	} elsif ($type == 4) {
	358	return -1;
	359	};
	360	return -1;
	361	}
	362
	363	############################## connection_failed ###############################
	364	# print failure message and return status 1
	365	# IN : @message : SMTP status message
	366	# OUT: 1
	367	sub connection_failed {
	368	my(@message)=@_;
	369	print " ! Connection failed or other temporary failure.\n" if !($options{'q'});
	370	printf(" %s\n",join(' ',@message)) if @message;
	371	return 1;
	372	}
	373
	374	__END__
	375
	376	################################ Documentation #################################
	377
	378	=head1 NAME
	379
	380	checkmail - check deliverability of a mail address
	381
	382	=head1 SYNOPSIS
	383
	384	B<checkmail> [B<-Vhqlr>] [B<-m> I<host>] I<address>\|B<-f> I<file>
	385
	386	=head1 REQUIREMENTS
	387
	388	=over 2
	389
	390	=item -
	391
	392	Perl 5.8 or later
	393
	394	=item -
	395
	396	File::Basename
	397
	398	=item -
	399
	400	Getopt::Std
	401
	402	=item -
	403
	404	Net::DNS I<(CPAN)>
	405
	406	=item -
	407
	408	Net::SMTP
	409
	410	=back
	411
	412	Furthermore you'll need a working DNS installation.
	413
	414	=head1 DESCRIPTION
	415
	416	checkmail checks the vailidity / deliverability of a mail address.
	417	You may submit just one address as the last argument or a file
	418	containing one address on each line using the B<-f> option.
	419
	420	=head2 Configuration
	421
	422	For the time being, all configuration is done in the script. You have
	423	to set the following elements of the %config hash:
	424
	425	=over 4
	426
	427	=item B<$config{'helo'}>
	428
	429	The hostname to be used for I<HELO> or I<EHLO> in the SMTP dialog.
	430
	431	=item B<$config{'from'}>
	432
	433	The sender address to be used for I<MAIL FROM> while testing.
	434
	435	=back
	436
	437	=head2 Usage
	438
	439	After configuring the script you may run your first test with
	440
	441	checkmail user@example.org
	442
	443	B<checkmail> will try to determine the mail exchanger(s) (MX)
	444	responsible for I<example.org> by querying the DNS for the respective
	445	MX records and then try to connect via SMTP (on port 25) to each of
	446	them in order of precedence (if necessary). It will run through the
	447	SMTP dialog until just before the I<DATA> stage, i.e. doing I<EHLO>,
	448	I<MAIL FROM> and I<RCPT TO>. If no MX is defined, B<checkmail> will
	449	fall back to the I<example.org> host itself, provided there is at
	450	least one A record defined in the DNS. If there are neither MX nor A
	451	records for I<example.org>, mail is not deliverable and B<checkmail>
	452	will fail accordingly. If no host can be reached, B<checkmail> will
	453	fail, too. Finally B<checkmail> will fail if mail to the given
	454	recipient is not accepted by the respective host.
	455
	456	If B<checkmail> fails, you'll not be able to deliver mail to that
	457	address - at least not using the configured sender address and from
	458	the host you're testing from. However, the opposite is not true: a
	459	mail you send may still not be delivered even if a test via
	460	B<checkmail> succeeds. The receiving entity may reject your mail after
	461	the I<DATA> stage, due to content checking or without any special
	462	reason, or it may even drop, filter or bounce your mail after finally
	463	accepting it. There is no way to be sure a mail will be accepted short
	464	of sending a real mail to the address in question.
	465
	466	You may, however, try to detect hosts that will happily accept any and
	467	all recipient in the SMTP dialog and just reject your mail later on,
	468	for example to defeat exactly the kind of check you try to do.
	469	B<checkmail> will do that by submitting a recipient address that is
	470	known to be invalid; if that address is accepted, too, you'll know
	471	that you can't reliably check the validity of any address on that
	472	host. You can force that check by using the B<-r> option.
	473
	474	If you don't want to see just the results of your test, you can get a
	475	B<complete log> of the SMTP dialog by using the B<-l> option. That may be
	476	helpful to test for temporary failure conditions.
	477
	478	On the other hand you may use the B<-q> option to suppress all output;
	479	B<checkmail> will then terminate with one of the following B<exit
	480	status>:
	481
	482	=over 4
	483
	484	=item B<0>
	485
	486	address(es) seem/seems to be valid
	487
	488	=item B<1>
	489
	490	temporary error (connection failure or temporary failure)
	491
	492	=item B<2>
	493
	494	address is invalid
	495
	496	=item B<3>
	497
	498	address cannot reliably be checked (test using B<-r> failed)
	499
	500	=back
	501
	502	You can do B<batch processing> using B<-f> and submitting a file with
	503	one address on each line. In that case the exit status is set to the
	504	highest value generated by testing all addresses, i.e. it is set to
	505	B<0> if and only if no adress failed, but to B<2> if even one address
	506	failed and to B<3> if even one addresses couldn't reliably be checked.
	507
	508	And finally you can B<suppress DNS lookups> for MX and A records and
	509	just force B<checkmail> to connect to a particular host using the
	510	B<-m> option.
	511
	512	B<Please note:> You shouldn't try to validate addresses while working
	513	from a dial-up or blacklisted host. If in doubt, use the B<-l> option
	514	to have a closer look on the SMTP dialog yourself.
	515
	516	=head1 OPTIONS
	517
	518	=over 3
	519
	520	=item B<-V> (version)
	521
	522	Print out version and copyright information on B<checkmail> and exit.
	523
	524	=item B<-h> (help)
	525
	526	Print this man page and exit.
	527
	528	=item B<-q> (quit)
	529
	530	Suppress output and just terminate with a specific exit status.
	531
	532	=item B<-l> (log)
	533
	534	Log and print out the whole SMTP dialog.
	535
	536	=item B<-r> (random address)
	537
	538	Also try a reliably invalid address to catch hosts that try undermine
	539	address verification.
	540
	541	=item B<-m> I<host> (MX to use)
	542
	543	Force a connection to I<host> to check deliverability to that
	544	particular host irrespective of DNS entries. For example:
	545
	546	checkmail -m test.host.example user@domain.example
	547
	548	=item B<-f> I<file> (file)
	549
	550	Process all addresses from I<file> (one on each line).
	551
	552	=back
	553
	554	=head1 INSTALLATION
	555
	556	Just copy checkmail to some directory and get started.
	557
	558	You can run your first test with
	559
	560	checkmail user@example.org
	561
	562	=head1 ENVIRONMENT
	563
	564	See documentation of I<Net::DNS::Resolver>.
	565
	566	=head1 FILES
	567
	568	=over 4
	569
	570	=item F<checkmail.pl>
	571
	572	The script itself.
	573
	574	=back
	575
	576	=head1 BUGS
	577
	578	Please report any bugs or feature request to the author or use the
	579	bug tracker at L<http://bugs.th-h.de/>!
	580
	581	=head1 SEE ALSO
	582
	583	L<http://th-h.de/download/scripts.php> will have the current
	584	version of this program.
	585
	586	This program is maintained using the Git version control system. You
	587	may clone L<git://code.th-h.de/mail/checkmail.git> to check out the
	588	current development tree or browse it on the web via
	589	L<http://code.th-h.de/?p=mail/checkmail.git>.
	590
	591	=head1 AUTHOR
	592
	593	Thomas Hochstein <thh@inter.net>
	594
	595	=head1 COPYRIGHT AND LICENSE
	596
	597	Copyright (c) 2002-2010 Thomas Hochstein <thh@inter.net>
	598
	599	This program is free software; you may redistribute it and/or modify it
	600	under the same terms as Perl itself.
	601
	602	=cut