[mail/checkmail.git] / checkmail.pl

#! /usr/bin/perl -W
#
# checkmail Version 0.5 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.5";

################################# 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 Mail::Address;
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:s:e:', \%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>] [-s <from>] [-e <EHLO>] <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 "  -s <from>  override configured value for MAIL FROM\n";
  print "  -e <EHLO>  override configured value for EHLO\n";
  print "  <address>  mail address to check\n\n";
  print "  -f <file>  parse file (one address per line)\n";
  exit(100);
};

# -s / -e: override configuration
$config{'from'} = $options{'s'} if $options{'s'};
$config{'helo'} = $options{'e'} if $options{'e'};

# -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 = $_;
  # regexp taken from http://www.regular-expressions.info/email.html
  # and escaping of "/" added two times
  if ($address !~ /^(?:[a-z0-9!#$%&'*+\/=?^_`{|}~-]+(?:\.[a-z0-9!#$%&'*+\/=?^_`{|}~-]+)*|"(?:[\x01-\x08\x0b\x0c\x0e-\x1f\x21\x23-\x5b\x5d-\x7f]|\\[\x01-\x09\x0b\x0c\x0e-\x7f])*")@(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\.)+[a-z0-9](?:[a-z0-9-]*[a-z0-9])?$/i) {
    printf("  > Address <%s> is syntactically INVALID.\n",$address) if !($options{'q'});
    $curstat = 2;
  } else {
    my $domain = Mail::Address->new('',$address)->host;
    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'}) {
        my ($success,$code,@message) = try_rcpt_to(\$smtp,create_rand_addr(Mail::Address->new('',$address)->host),$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;
}

############################### 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>]  [-s I<sender>] [-e I<EHLO>] I<address>|B<-f> I<file>

=head1 REQUIREMENTS

=over 2

=item -

Perl 5.8 or later

=item -

File::Basename

=item -

Getopt::Std

=item -

Mail::Address I<(CPAN)>

=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

You may override that configuration by using the B<-e> and B<-s>
command line options.

=head2 Usage

After configuring the script you may run your first test with

    checkmail user@example.org

B<checkmail> will check the address for syntactic validity. If the
address is valid, it 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.

B<Please note:> To avoid shell expansion on addresses you submit to
B<checkmail>, use B<batch processing>.

=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<-s> I<sender> (value for MAIL FROM)

Override configuration and use I<sender> for MAIL FROM.

=item B<-e> I<EHLO> (value for EHLO)

Override configuration and use I<EHLO> for EHLO.

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