#! /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;
  }