#! /usr/bin/perl
#
use strict;
use warnings;
use Socket;
use Net::DNS;
select((select(STDOUT), $| = 1)[0]); # Unbuffer STDOUT.
my %formData = getOrPost();
unless (scalar (keys(%formData))) {die;}
# Load up the variables passed from the web form.
my $userecursion = ($formData{'userecursion'} eq 'on') ? 1 : 0;
my $zonexfer = ($formData{'zonexfer'} eq 'on') ? 1 : 0;
my $showtimings = ($formData{'showtimings'} eq 'on') ? 1 : 0;
my $sendashtml = ($formData{'sendashtml'} eq 'on') ? 1 : 0;
my $from = lc $formData{'mailfrom'};
my $to = lc $formData{'mailto'};
my $subj = $formData{'mailsubj'};
my $msgbdy = $formData{'mailbody'};
my $protocol = (getprotobyname('tcp'))[2];
my $mailport = (getservbyname('smtp', 'tcp'))[2];
my $prefix = ' ' x 27;
# Create a DNS RESOLVER object.
if (my $resolver = Net::DNS::Resolver -> new)
{
$| = 1; # Set autoflush on. For some reason this is necessary (??).
$resolver -> retry(2); # Set the retry count to 2. Default is 4.
$resolver -> retrans(3); # Set the interval between retries. Default is 5.
$resolver -> defnames(0); # Disable appending default domain name. Default is 1.
# Get the domain part of the email address.
my ($junk, $domain) = split(/\@/, $to);
# DEMONSTRATION ONLY - the following two lines of code (that do exactly
# the same thing) are not necessary. This example demonstrates that the
# 'nameservers' object is simply a key in a hash of arrays inside the
# resolver object. The array @nameservers (note case) is not used anywhere
# in this program.
#
# Likewise, the two lines of code that follow this example display yet
# another way of extracting the list of name servers.
#
my @nameservers = $resolver -> nameservers();
@nameservers = @{${$resolver}{'nameservers'}};
# use the resolver QUERY method to return a PACKET object containing
# all name server records for the query domain, then extract the
# RESOURCE RECORDS of the name servers into array @nameServers.
#
# All this does is retrieve the nameserver(s) for the target domain
# using your local name server's query mechanism. The data for other
# target domain records is likely to be non-authoritative.
#
my $packetNS = $resolver -> query($domain, 'NS');
my @nameServers = $packetNS -> answer if (defined $packetNS);
if (@nameServers)
{
# Extract the count of header objects contained within the packet
# that was returned from the previous call to '$resolver -> query'.
#
print "Resolver reports ", $packetNS -> header -> ancount, "name servers for domain $domain.\n ";
# Each item in the @nameServers list is a RESOURCE RECORD.
# The array returned from '$packetNS -> answer' is not in
# any particular particular order and can be different from
# session to session.
#
foreach my $rrNS (@nameServers)
{
$resolver -> recurse($userecursion); # Set this flag to perform recursive queries. Default is 1.
# Get the name server NAME property of the resource record.
# $ns is a string like 'ns1.microsoft.com'.
my $ns = $rrNS -> nsdname;
# use the resolver to query name server $ns for any (A)ddress
# records for our target domain.
#
my $packetA = $resolver -> query($ns, 'A');
my @addresses = $packetA -> answer if (defined $packetA);
if (@addresses)
{
foreach my $rrIP (@addresses)
{
my $ipaddr = $rrIP -> address;
my $ipname = $rrIP -> name;
# ==== SET THE RESOLVER TO QUERY THIS IP ADDRESS ====
$resolver -> nameservers($ipaddr);
# As an excercise, attempt to do a zone transfer, which we do not
# really need for this application. If the operation succeeds, then
# print the zone record to the output.
#
if ($zonexfer)
{
my @zone = $resolver -> axfr($domain);
if (@zone)
{
print "Zone transfer on $ipname $ipaddr is ENABLED";
$resolver -> print foreach (@zone);
}
}
# Query the current IP address for the SOA record. Resolver default
# name server has been set. Turn recursion off to ensure that the SOA
# record comes from this specific server.
$resolver -> recurse(0);
my $packetSOA = $resolver -> send($domain, 'SOA', 'IN');
unless (defined($packetSOA)) {next;}
print "Answer returned from: " $packetSOA -> answerfrom;
# Print the SOA header.
print ($packetSOA -> answer)[0] -> string;
# Retrieve the SOA packet's header object which will contain an 'aa'
# property if this name server is authoritative for the target domain.
if ($packetSOA -> header -> aa)
{
# use the mx() method of the resolver object to extract a PACKET object
# which will contain one or more RESOURCE RECORDS representing mail
# servers for the target domain. The resource records will be sorted by
# priority. The Resolver default name server has previously been set.
my @packetMX = mx($resolver, $domain);
if (@packetMX)
{
# Go through the MX RESOURCE RECORDS one at a time.
foreach my $rrMX (@packetMX)
{
# Get a list of possibly multiple IP addresses in the
# MX resource record.
my @ipaddrs = (gethostbyname($rrMX -> exchange))[4];
# Try to connect to each IP address for the current mail server,
# stopping when we achieve success.
foreach my $mailhost (@ipaddrs)
{
# Pass this mail server to the routine that performs the SMTP transaction.
unless (sendSMTP($mailhost, $mailport, $protocol, $domain)) {$alldone = 1; last;}
}
last if $alldone;
}
}
last if $alldone;
}
}
last if $alldone;
}
}
}
}
#----------------------------------------------------------
sub sendSMTP
{
my ($mailhost, $mailport, $protocol, $domain) = @_;
# NOTE that in an SMTP server conversation, a return
# code which begins with a "4" or "5" is an error.
#
my $maildate = RFC822date();
my $serverReturn = '';
# Open a TCP socket and name it 'MAIL'.
if (socket(MAIL, AF_INET, SOCK_STREAM, $protocol))
{
select((select(MAIL), $| = 1)[0]); # Unbuffer the socket.
# Connect the MAIL socket to the target mail server.
if (connect(MAIL, pack('Sna4x8', AF_INET, $mailport, $mailhost)))
{
$serverReturn = <MAIL>;
if ($serverReturn =~ /^[45]/)
{close(MAIL); return endSMTP(1);}
print "server says -- $serverReturn\n";
# -------------------------------------------------------------
print MAIL "helo $domain\r\n";
$serverReturn = <MAIL>;
if ($serverReturn =~ /^[45]/)
{close(MAIL); return endSMTP(2);}
print "server says -- $serverReturn\n";
# -------------------------------------------------------------
print MAIL "mail from: <$from>\r\n";
$serverReturn = <MAIL>;
if ($serverReturn =~ /^[45]/)
{close(MAIL); return endSMTP(3);}
print "server says -- $serverReturn\n";
# -------------------------------------------------------------
# Do a "RCPT TO:" command for each "to" address.
foreach (split(/,/, $to))
{
print MAIL "rcpt to: <$_>\r\n";
$serverReturn = <MAIL>;
if ($serverReturn =~ /^[45]/)
{close(MAIL); return endSMTP(4);}
print "server says -- $serverReturn\n";
}
# -------------------------------------------------------------
print MAIL "data\r\n";
$serverReturn = <MAIL>;
if ($serverReturn =~ /^[45]/)
{close MAIL; return endSMTP(5);}
print "server says -- $serverReturn\n";
# Begin the mail header part of the msg body...
if ($sendashtml)
{
print MAIL "Content-type: text/html; charset=us-ascii\r\n";
print MAIL "MIME-Version: 1.0\r\n";
print MAIL "Content-Transfer-Encoding: 7bit\r\n";
}
print MAIL "To: $to\r\n";
print MAIL "From: $from\r\n";
print MAIL "x-mta: mailtest engine\r\n";
print MAIL "Reply-to: $from\r\n";
print MAIL "Date: $maildate\r\n";
print MAIL "Sent: $maildate\r\n";
print MAIL "Subject: $subj\r\n\r\n";
# End mail header.
# -------------------------------------------------------------
if ($sendashtml)
{
print MAIL "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"\r\n";
print MAIL " \"http://www.w3.org/TR/html4/loose.dtd\">\r\n";
print MAIL "<html>\r\n";
print MAIL "<head>\r\n";
print MAIL "<title>$subj</title>\r\n";
print MAIL "<style type=\"text/css\">body {font: normal normal normal 16px/20px candara, sans-serif; color: #0066aa;}\r\n";
print MAIL "</head>\r\n<body>\r\n";
}
print MAIL "$msgbdy\r\n";
if ($sendashtml) {print MAIL "</body>\r\n</html>\r\n";}
# Send a '.' on a separate line to indicate the end of the message.
print MAIL "\r\n.\r\n";
$serverReturn = <MAIL>;
if ($serverReturn =~ /^[45]/)
{close(MAIL); return endSMTP(6);}
print "server says -- $serverReturn\n";
# -------------------------------------------------------------
print MAIL "quit\r\n";
$serverReturn = <MAIL>;
if ($serverReturn =~ /^[45]/)
{close(MAIL); return endSMTP(7);}
print "server says -- $serverReturn\n";
# -------------------------------------------------------------
}
else
{
print "Unable to connect to mailhost ", inet_ntoa($mailhost), "\n";
}
close MAIL;
}
return endSMTP(0);
}
#----------------------------------------------------------
sub endSMTP
{
my $rtncode = shift;
print "<p><pre> <b>End of SMTP session.</b><br />\n";
print "------------------------------------------------------------------------------</pre></p><br />\n";
return $rtncode;
}
#----------------------------------------------------------
sub getOrPost
{
my ($qryString, %formData);
# Retrieve the variable(s) from the web request.
if ($ENV{REQUEST_METHOD} eq 'POST')
{read(STDIN, $qryString, $ENV{CONTENT_LENGTH});}
elsif ($ENV{REQUEST_METHOD} eq 'POST')
{$qryString = $ENV{QUERY_STRING};}
# If there is no query string, it is possible that the program
# is being run under test and the parameters are specified on
# the command line. Look for them.
unless ($qryString)
{
if (scalar @ARGV) {$qryString = $ARGV[0];}
}
my @qryArray = split /&/, $qryString;
foreach my $qryAtom (@qryArray)
{
# Split the fieldname/value into separate name and fields.
my ($qryName, $qryValue) = split /=/, $qryAtom;
# Convert the encoded characters (example %20) into the ASCII chars they represent.
$qryValue =~ s/%([a-fA-F0-9]{2})/pack("C", hex($1))/eg;
# Convert any '+' chars into spaces.
$qryValue =~ s/\+/ /g;
$formData{$qryName} = $qryValue;
}
return %formData;
}
#----------------------------------------------------------
# GEFARGLE the date into the approved network format which
# looks like this: Wed, 03 Sep 2008 08:58:27 -0800.
#
# CALL WITH: RFC822date( [date in Perl epoch format] );
#
# The range of world time zones spans UTC -11 to UTC +12.
#
sub RFC822date
{
my $ltime = shift || time();
# Instantiate 2 arrays for local lookups.
my @weekdays = qw(Sun Mon Tue Wed Thu Fri Sat Sun);
my @monthnames = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my ($sec, $min, $hor, $day, $mon, $year, $weekday) = (localtime($ltime))[0..6];
my $gtime = timegm($sec, $min, $hor, $day, $mon, $year, $weekday);
$year += 1900;
# Calc how many hours we differ from GMT time plus or minus. Determine
# which sign '+' or '-' to use for display purposes.
my $gmtoset = ($gtime - $ltime) / 3600;
my $TZsign = ($gmtoset =~ s/^-//) ? '-' : '+';
# Separate the GMT offset into integer and decimal (if any) components in
# order to handle time zones that are not offset an exact hour from GMT
# such as Arizona. Force the fractional component to be 0 if there is no
# fractional component. If there *is* a fractional component, convert the
# component to minutes. Format the integer and fractional components to
# be two chars with a leading 0 if necessary. Finally, combine the integer
# and decimal components into a single string and prefix the sign.
#
my ($gmtint, $gmtfrac) = split /\./, $gmtoset;
$gmtfrac = 0 unless $gmtfrac;
$gmtfrac = ($gmtfrac / 10) * 60;
$gmtfrac =~ /^(\d{1,2})/;
$gmtfrac = $1;
$gmtint = "0$gmtint" unless $gmtint > 9;
$gmtfrac = "0$gmtfrac" unless $gmtfrac > 9;
$gmtoset = $TZsign . $gmtint . $gmtfrac;
# Format the day, hour, minute and second.
$day = "0$day" unless $day > 9;
$hor = "0$hor" unless $hor > 9;
$min = "0$min" unless $min > 9;
$sec = "0$sec" unless $sec > 9;
return
"$weekdays[$weekday], " .
"$day " .
"$monthnames[$mon] " .
"$year " .
"$hor:$min:$sec " .
"$gmtoset";
}
#----------------------------------------------------------
# GEFARGLE the date into the approved network format which
# looks like this: Wed, 03 Sep 2008 08:58:27 -0800.
#
# CALL WITH: RFC822date( [ date in time() format ] ['gmt'] );
#
sub RFC822date
{
my @weekdays = qw(Sun Mon Tue Wed Thu Fri Sat Sun);
my @monthnames = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my ($tsec, $tmin, $thor, $tday, $tmon, $tyear, $twday, $tyday, $tisdst) = localtime(time());
if (my $dateArg = shift)
{
if (my $gmTimeArg = shift)
{
if (lc $gmTimeArg eq 'gmt')
{
($tsec, $tmin, $thor, $tday, $tmon, $tyear, $twday, $tyday, $tisdst) = gmtime($dateArg);
}
}
}
$tyear += 1900;
$tday = pad($tday, 2, '0', 'r');
$thor = pad($thor, 2, '0', 'r');
$tmin = pad($tmin, 2, '0', 'r');
$tsec = pad($tsec, 2, '0', 'r');
my $datestr = "$weekdays[$twday], $tday $monthnames[$tmon] $tyear $thor:$tmin:$tsec";
$datestr .= $tisdst ? '-0700' : '-0800';
return $datestr;
}
#--------------------------------------
# Pads a string with blanks (or whatever).
# Takes 4 args:
# 1. The string you want padded (required).
# 2. The resulting length (default is 10).
# 3. The char to use for padding (default is 'space').
# 4. Justification. Default is 'r' for right-justified,
# which fills the left side with the pad character.
sub pad
{
my ($str, $len, $padchar, $just) = @_;
$len = $len ? $len : 10;
$just = ($just =~ /[lL]/) ? lc $just : 'r';
$padchar = $padchar eq '' ? ' ' : substr($padchar, 0, 1);
if (length($str) == 0)
{
$str = $padchar x $len;
}
else
{
if (length($str) < $len)
{
if ($just eq 'l') {$str .= $padchar x ($len - length($str));}
else {$str = ($padchar x ($len - length($str))) . $str;}
}
else
{
if ($just eq 'l')
{
$str = substr $str, 0, $len; $str =~ s/\s+$//g;
if (length($str) < $len) {$str .= $padchar x ($len - length($str));}
}
else
{
$str = substr $str, -$len; $str =~ s/^\s+//g;
if (length($str) < $len) {$str = ($padchar x ($len - length($str))) . $str;}
}
}
}
return $str;
}