#!/usr/local/bin/perl

# CGI::Request_mailer.pm
#   Processes and emails a request submitted via an HTML form
#
#   Initial ideas borrowed from mail.pl by Brian Exelbierd (bex@ncsu.edu)
#
#   02/22/2003 Version 1.1.5
#   Use and distribute this script as per the Artistic License
#   Copyright (C) 2005 Igor S. Livshits <mailto:request-mailer@ayradyss.org>

# Fields expected from the calling form:
#   Fields          Description of the form fields
#                     e.g., "1,n1;0,n2;2,n3,n4;;3r1,n5,n6,n7"
#                     where the number indicates status, such as
#                       1 = mandatory field
#                       0 = optional field
#                       N = N of the next fields form one mandatory datum
#                       NrM = at least M of the next N fields are mandatory
#                     and n# indicates the name of the field.
#                     An empty ;; indicates a blank line for formatting
#                     Field names may not contain white spaces,
#                       but all underscores within field names will become
#                       spaces when printed.
#                     You may, however, use white spaces to format
#                       your HTML code as this module ignores them.
#   Email           From whom I'll send the form
#   MailSubject     Text for the Subject: line of our note
#   OperatorName    Text describing the MailToAddress; e.g., a real name
#
#   You may rename these fields as long as you also update
#   the associative array %requiredFields (below).
#
# Optional fields (used if defined):
#   MailToAddress   To whom I'll send the form (please use a hard-coded value!)
#   SuccessNote     Text to append to the end of the success header
#   MailStart       Text to prepend to our request message
#   MailEnd         Text to append to our request message
#   CallerURL       The object that invokes the form; used for return address
#   CallerTitle     Text used to construct the return link
#                     e.g., <a href="http://CallerURL">CallerTitle</a>


# Specify package
# 
package CGI::Request_mailer;
use Exporter;

@ISA= qw(Exporter);
@EXPORT=(Run);


# Define libraries and modules
#
use CGI qw(:standard);          # a perl5 CGI library by L. Stein
use Net::SMTP;                  # from libnet by Graham Barr
use Net::DNS;                   # Net-DNS-0.12


#
# Methods
#

# Constructor
#
sub new
{
  my $type= shift;              # skim off the class reference

  my $self= {};                 # create this object

  bless $self, $type;           # connect the hash to the class
  $self->Initialise(@_);        # initialise it
  return $self;                 # and return a reference to it
}


# Initialise
#   Set up and sanity check all instance variables
#
sub Initialise
{
  my $self= shift;              # skim off the class reference
  my %requiredFields=           # set up default required fields
    (
     'Fields' => 'Fields',
     'MailSubject' => 'MailSubject',
     'OperatorName' => 'OperatorName',
     );

  $self->{CGI}= new CGI();      # our CGI data

  $self->True(1==1);            # set up overridable constants
  $self->False(1==0);
  $self->FieldGroupDelimiter(";");
  $self->FieldDelimiter(",");
  $self->FieldOptionDelimiter("r");
  $self->LogicDelimiterAnd(" and ");
  $self->LogicDelimiterOr(" or ");
  $self->HTMLLineBreak($self->{CGI}->br);

  $self->Error("No error.");    # clear error conditions
  $self->ErrorDescription("No error.");

  $self->RequiredFields(\%requiredFields);
  $self->Fields(0);             # no fields yet
  $self->Message("");           # no message yet
  $self->MailToAddress(shift);  # over-ride with a passed mail to address (for security)
  $self->ReportHeader(shift);   # report header file name
  $self->ReportFooter(shift);   # report footer file name
  $self->Valid($self->False()); # no valid fields yet
}


# Run
#   Do our duty
#
sub Run
{
  my $self= shift;              # skim off the class reference

  return $self->False() unless $self->ConfirmData();
  return $self->False() unless $self->ConfirmRequiredFields();

  $self->CollectMailToAddress() unless $self->MailToAddress();
  $self->CollectRequestedFields();
  $self->ProcessRequest();
}


#
# Methods which return constants
#

# True
#   Returns a boolean true
#
sub True
{
  my $self = shift;             # skim off the class reference

  if (@_) { $self->{TRUE}= shift; } # check for a new value and assign it
  return $self->{TRUE};         # return current value
}


# False
#   Returns a boolean false
#
sub False
{
  my $self= shift;

  if (@_) { $self->{FALSE}= shift; }
  return $self->{FALSE};
}


# FieldGroupDelimiter
#   That which separates requested field groups
#
sub FieldGroupDelimiter
{
  my $self= shift;

  if (@_) { $self->{FIELDGROUPDELIMITER}= shift; }
  return $self->{FIELDGROUPDELIMITER};
}


# FieldDelimiter
#   That which separates requested fields
#
sub FieldDelimiter
{
  my $self= shift;

  if (@_) { $self->{FIELDDELIMITER}= shift; }
  return $self->{FIELDDELIMITER};
}


# FieldOptionDelimiter
#   That which separates options for a given field group
#
sub FieldOptionDelimiter
{
  my $self= shift;

  if (@_) { $self->{FIELDOPTIONDELIMITER}= shift; }
  return $self->{FIELDOPTIONDELIMITER};
}


# LogicDelimiterAnd
#   Joins mandatory members of a group
#
sub LogicDelimiterAnd
{
  my $self= shift;

  if (@_) { $self->{LOGICDELIMITERAND}= shift; }
  return $self->{LOGICDELIMITERAND};
}


# LogicDelimiterOr
#   Joins optional members of a group
#
sub LogicDelimiterOr
{
  my $self= shift;

  if (@_) { $self->{LOGICDELIMITEROR}= shift; }
  return $self->{LOGICDELIMITEROR};
}


# HTMLLineBreak
#   HTML code for a line break 
#
sub HTMLLineBreak
{
  my $self= shift;

  if (@_) { $self->{HTMLLINEBREAK}= shift; }
  return $self->{HTMLLINEBREAK};
}


#
# Methoids which access instance variables
#

# Error
#   The last error message
#
sub Error
{
  my $self= shift;

  if (@_) { $self->{ERROR}= shift; }
  return $self->{ERROR};
}


# ErrorDescription
#   The last error verbose desctiption
#
sub ErrorDescription
{
  my $self= shift;

  if (@_) { $self->{ERRORDESCRIPTION}= shift; }
  return $self->{ERRORDESCRIPTION};
}


# Valid 
#   A validity flag for our form
#
sub Valid
{
  my $self= shift;

  if (@_) { $self->{VALID}= shift; }
  return $self->{VALID};
}


# RequiredFields 
#   A pointer to the hash of required fields
#
sub RequiredFields
{
  my $self= shift;

  if (@_) { $self->{REQUIREDFIELDS}= shift; }
  return $self->{REQUIREDFIELDS};
}


# Fields 
#   A pointer to the array of user fields
#
sub Fields
{
  my $self= shift;

  if (@_) { $self->{FIELDS}= shift; }
  return $self->{FIELDS};
}


# Message 
#   A pointer to the text message compiled from form data
#
sub Message
{
  my $self= shift;

  if (@_) { $self->{MESSAGE}= shift; }
  return $self->{MESSAGE};
}


# MailToAddress 
#   The mail to address used for sending the e-mail message
#
sub MailToAddress
{
  my $self= shift;

  if (@_) { $self->{MAILTOADDRESS}= shift; }
  return $self->{MAILTOADDRESS};
}


# ReportHeader
#   A file name for the report header
#
sub ReportHeader
{
  my $self= shift;

  if (@_) { $self->{REPORTHEADER}= shift; }
  return $self->{REPORTHEADER};
}


# ReportFooter
#   A file name for the report footer
#
sub ReportFooter
{
  my $self= shift;

  if (@_) { $self->{REPORTFOOTER}= shift; }
  return $self->{REPORTFOOTER};
}


#
# Methods which process data
#

# ConfirmData
#   Confirms that our CGI object has data and reports an error if not
#
sub ConfirmData
{
  my $self= shift;

  if (!$self->{CGI}->param())
  {                             # no arguments were passed, print an error
    print $self->{CGI}->header();
    print $self->{CGI}->start_html('No arguments passed'),
    $self->{CGI}->h3('Error: No data!'),
    "<p>Apparently, you invoked this program from something other \n",
    "than its parent form. It simply won't do you any good this way.</p>\n";
    print $self->{CGI}->end_html;
    return $self->False();
  }
  else { return $self->True(); }
}


# ConfirmRequiredFields
#   Confirms that our CGI object received all the required fields
#
sub ConfirmRequiredFields
{
  my $self= shift;
  my @missingFields= ();        # Accummulating array of ommitted fields
  my $error;                    # Our complaint about missing fields
  my %requiredFields;           # Temporary storage while we confirm
  my $requiredFieldKey;         #   required fields
  my $requiredFieldName;

  %requiredFields= %{$self->RequiredFields()};
  
  while (($requiredFieldKey, $requiredFieldName)= each %requiredFields)
  {
    push(@missingFields, $requiredFieldName)
      unless $self->{CGI}->param($requiredFieldKey);
  }

  if (@missingFields > 0)
  {                             # We have some missing fields, report this
    if (@missingFields == 1)
    {
      $error= "<p>Required field ommitted:</p>\n";
    }
    else
    {
      $error= "<p>Required fields ommitted:</p>\n";
    }
    $error.= "<ol>\n";
    foreach $missingField (@missingFields)
    {                           # dump missing fields as an ordered list
      $error.= "<li>". $missingField."\n"; 
    }
    $error.= "</ol>\n";
    $self->ErrorDescription($error);
    $self->ReportMisconfiguration();
    return $self->False();
  }
  else { return $self->True(); }
}


# CollectMailToAddress
#   For backward compatibility only
#   This feature may be abused to relay spam through your unprotected CGI!
#
sub CollectMailToAddress
{
  my $self= shift;              # skim off the class reference
  
  $self->MailToAddress($self->{CGI}->param('MailToAddress'));
}


# CollectRequestedFields
#   Confirms that our CGI object received all the requested fields
#
sub CollectRequestedFields
{
  my $self= shift;              # skim off the class reference
  
  my $requestedFieldTokens;     # tokens from the calling form
  my @requestedFields= ();      # a list of filled fields
  my @missingFields= ();        # a list of unfilled but requested fields
  my $fieldGroup;               # related fields on the form
  my $fieldName;                # the name of the current field
  my @fields;                   # a list fo fields within a field group
  my $fieldGroupCount;          # total number of fields within a group
  my $fieldGroupOption;         # total number of required fields in a group
  my $fieldLogicDelimiter;      # logical field relationship within a group
  
  # Process our tokens to see which fields were requested
  $requestedFieldTokens= $self->{CGI}->param('Fields');
  $requestedFieldTokens=~ s/\s+//g; # kill spaces

 ProcessGroups:                 # iterate through our tokens group by group
  foreach $fieldGroup
    (split($self->FieldGroupDelimiter(), $requestedFieldTokens))
  {
    if ($fieldGroup=~ /^\d/)    # make sure this is not a blank indicator
    {                           # process a field group
      @fields= split($self->FieldDelimiter(), $fieldGroup);
      $fieldGroupCount= shift(@fields);
      ($fieldGroupCount, $fieldGroupOption)=
        split($self->FieldOptionDelimiter(), $fieldGroupCount);
      if ($fieldGroupOption)
      {                         # not all members of this group are necessary
        if ($fieldGroupCount < $fieldGroupOption)
        {                       # mandatory count cannot exceed total count
          $self->ErrorDescription("Misconfigured field group: "
                           . "Mandatory v. optional miscount [$fieldGroup]");
          $self->ReportMisconfiguration();
          return ($self->False());
        }
        $fieldLogicDelimiter= $self->LogicDelimiterOr();
      }
      else
      {                         # each member of this group is necessary
        # define optional count to equal mandatory for later error checks
        $fieldGroupOption= $fieldGroupCount;
        $fieldLogicDelimiter= $self->LogicDelimiterAnd();
      }
    }
    else
    {                           # add a separator to our list of fields
      push(@requestedFields, $self->HTMLLineBreak());
      next ProcessGroups;       # this group was merely a separator
    }
    
    if ($fieldGroupCount == 0)
    {                           # this field group is entirely optional
      $fieldLogicDelimiter= ""; # clear for the first field
      foreach $fieldName (@fields)
      {
        if ($self->ConfirmField($fieldName))
        {                       # add an optional completed field
          push(@requestedFields, $fieldLogicDelimiter)
            if $fieldLogicDelimiter; # separate multiple fields

          push(@requestedFields, $fieldName);
          $fieldLogicDimiter= $self->LogicDelimiterAnd();
        }
      }
      next ProcessGroups;       # collected all filled optional fields
    }
    
    if ($fieldGroupCount != @fields)
    {                           # mandatory count must equal listed fields
      $self->ErrorDescription("Misconfigured field group: "
                           . "Count v. list mismatch [$fieldGroup]");
      $self->ReportMisconfiguration();
      return ($self->False());
    }
    
    foreach $fieldName (@fields)
    {
      if ($self->ConfirmField($fieldName))
      {                         # add a mandatory completed field
        push(@requestedFields, $fieldName);
        if (--$fieldGroupOption)
        {                       # indicate a multi-field group
          push(@requestedFields, $self->LogicDelimiterAnd());
        }
        else
        {
          next ProcessGroups;   # found all filled mandatory fields
        }
      }
    }

    # Add missing requested fields to our list
    push(@missingFields, join($fieldLogicDelimiter, @fields));
  }
  
  if (@missingFields > 0)
  {                             # not all requested fields were filled
    $self->Valid($self->False());
    $self->Fields(\@missingFields);
  }
  else
  {                             # got all requested fields
    $self->Valid($self->True());
    $self->Fields(\@requestedFields);
  }
}


# ConfirmField
#   Comfirms a data field as legitimate
#     This additional trapping is necessary due to a bug(?) in CGI.pm
#     manifested by gratuitous spaces in empty fields.
#
sub ConfirmField
{
  my $self= shift;
  my $fieldName= shift; # Current field's name

  # Some versions fo CGI.pm put gratuitous white spaces into text area
  #   fields that are really empty. Then again, a user may do such
  #   as well. We will ignore both situations.

  if ($self->{CGI}->param($fieldName)=~ /\S/)
  {                             # must contain a non-whitespace char
    return $self->True();       #  to be legitimate
  }
  else { return $self->False(); }
}

# ReportMisconfiguration
#   Report an error within the original form (operator error)
#
sub ReportMisconfiguration
{
  my $self= shift;
  my $description;              # Verbose error description

  $self->Error("Request form misconfigured");
  $description=
    "<p>The request form you just submitted contained errors.</p>\n" .
    "<p>Please alert its author to this problem.\n";
  if ($self->MailToAddress())
  {                             # check for operator's email address
    $description.= " <a href=\"mailto:";
    $description.= $self->MailToAddress();
    $description.= "\">";
    if ($self->{CGI}->param('OperatorName'))
    {                           # check for operator's name
       $description.= $self->{CGI}->param('OperatorName');
    }
    else
    {                           # don't have a name, will use address for text
      $description.= $self->MailToAddress();
    }
    $description.=
      "</a> may be an appropriate contact. \n" .
      "However, since the form was misconfigured in the first place, \n" .
      "this email address may be bogus.</p>\n";
  }
  $description.= "<hr>\n" . $self->ErrorDescription();
  $self->ErrorDescription($description); # update the error description

  $self->ReportError();
}


# ProcessRequest
#   Process submitted request
#
sub ProcessRequest
{
  my $self= shift;              # skim off the class reference

  if ($self->Valid())           # check our data validity flag
  {                             # report completed fields
    $self->CompileRequest();
    $self->SendRequest();
    $self->ReportSuccess();
  }
  else                          # apparently, our data is NOT valid
  {                             # report missing fields
    $self->ReportMissingRequestedFields();
  }
}


# ReportMissingRequestedFields
#   Report uncompleted form (user error)
#
sub ReportMissingRequestedFields
{
  my $self= shift;
  my $error;                    # Verbose error description

  $self->Error("Requested fields missing");
  $error=
    "<p>Apparently, you forgot to complete all mandatory fields. \n" .
    "Please return and enter the missing information.</p>\n" .
    "<hr>\n";
  if (@{$self->Fields()} > 0)
  {                             # list the missing fields
    if (@{$self->Fields()} == 1)
    {
      $error= "<p>Requested field left blank:</p>\n";
    }
    else
    {
      $error= "<p>Requested fields left blank:</p>\n";
    }
    $error.=
      "<ol>\n" .
      "<li>" .
      join("\n<li>", @{$self->Fields()}) .
      "</ol>\n";
  }
  $self->ErrorDescription($error); # update the error description

  $self->ReportError();
}


# ReportError
#   Report an error.
#
sub ReportError
{
  my $self= shift;
  my $errorReport= "";

  if ($self->ReportHeader())
  {
    $errorReport= $self->CreateReport($self->{CGI}->h3("Error: " . $self->Error()) .
                                      $self->ErrorDescription());
  }

  if ($errorReport)
  {
    print $self->{CGI}->header();
    print $errorReport;
  }
  else
  {
    print $self->{CGI}->header();
    print 
      $self->{CGI}->start_html($self->Error()),
      $self->{CGI}->h3("Error: " . $self->Error()),
      $self->ErrorDescription();
    print $self->{CGI}->end_html;
  }
}


# CreateReport
#   Compile a report web page from a header, a message, and a footer
#
sub CreateReport
{
  my $self= shift;
  my $message= shift;           # capture the report message
  my $text= "";
  my $headerFile= $self->ReportHeader();
  my $footerFile= $self->ReportFooter();

  open(Header, $headerFile)     # attempt to read from the file or punt on error
    or return $text;
  while (<Header>)
  {                             # accumulate the header
    $text.= $_;
  }
  close(Header);

  $text.= $message;             # insert the message

  open(Footer, $footerFile)     # attempt to read from the file or punt on error
    or return $text . $self->{CGI}->end_html;
  while (<Footer>)
  {                             # append the footer lines
    $text.= $_;
  }
  close(Footer);

  return $text;
}


# CompileRequest
#   Compile the variables and values into a text message
#
sub CompileRequest
{
  my $self= shift;
  my $field;                    # Holds a field for processing
  my $message= "";              # Our text message as we accumulate it
  my $values;                   # Values from the form
  my $value;                    # A given form value
  my $valueTrailer= "";         # For pretty text formatting
  my $endOfLine;                # A flag for an end of a text line

  $endOfLine= $self->False();   # just starting...
  $values= ": ";                # prime the string for the first value
  foreach $field (@{$self->Fields()})
  {
    if ($field eq $self->HTMLLineBreak())
    {                           # finish the previous line with an extra return
      $values.= "\n";
      $endOfLine= $self->True();
      next;
    }
    
    if ($field eq $self->LogicDelimiterAnd())
    {                           # separate fields on the same line
      $message.= $self->LogicDelimiterAnd();
      $values.= " ";            # separate same line values with a space
      $endOfLine= $self->False();
      next;
    }
    
    if ($endOfLine)
    {
      $message.= "$values";     # finish off the previous line
      $message.= "\n";
      $values= ": ";            # clear the values string
      if ($self->{CGI}->param($field) =~ /\n/)
      {                         # check for a multi-line value
        $values.= "\n";         #   and format our message accordingly
        $valueTrailer= "\n";    #   by forcing the value beneath the tag
      }                         #   and by forcing a blank line below it
      # clean up and append the first value for this line
      $value= $self->{CGI}->param($field);
      $value=~ s/^\s+//;        # drop leading white spaces
      $value=~ s/\s+$//;        # drop trailing white spaces
      $values.= $value . $valueTrailer;
      $valueTrailer= "";
    }
    else
    {
      $endOfLine= $self->True(); # assume this is the last field on this line
      # clean up and store another value for this line
      $value= $self->{CGI}->param($field);
      $value=~ s/^\s+//;        # drop leading white spaces
      $value=~ s/\s+$//;        # drop trailing white spaces
      $values.= $value . $valueTrailer;
      $valueTrailer= "";
    }
    $field=~ s/_/ /g;           # replace all underscores with spaces
    $message.= $field;          # enter the field name
  }

  $message.= "$values\n";       # finish off the last line
  $self->Message($message);     # preserve the message
  return;
}


# SendRequest
#   Email the request to the operator with a copy to the user
#
sub SendRequest
{
  my $self= shift;
  my $mailMessage;              # the body of our email message
  my $mailer;                   # the object which will send our message
  my $address;                  # requestor's email address

  # Validate user's email address
  $address= $self->ConfirmEmailAddress();

  # Prepend a leader to our message
  $_= $self->{CGI}->param('MailStart');
  s/\\n/\n/g;                   # convert all newline codes into real newlines
  $mailMessage= $_ . $self->Message();

  # Append a trailer to our message
  $_= $self->{CGI}->param("MailEnd");
  s/\\n/\n/g;                   # convert all newline codes into real newlines
  $mailMessage.= $_;

  # Mail the message
  unless ($mailer= new Net::SMTP())
  {                             # libnet-configured mailer failed
    unless ($mailer= new Net::SMTP("localhost"))
    {                           # host machine as a mailer failed, too
      $self->Error("Mailer error");
      $self->ErrorDescription("Net:SMTP likely misconfigured: Cound not create connections to send mail.");
      $self->ReportError();
      exit;
    }
  }

  if ($mailer->mail($address)
      && $mailer->to($self->MailToAddress())
      && $mailer->to($address))
  {
    $mailer->data();
    $mailMessage= 
      "To: ". $self->MailToAddress(). "\n".
      "Cc: ". $self->{CGI}->param('Email'). "\n".
      "From: ". $self->{CGI}->param('Email'). "\n".
      "Reply-To: ". $self->{CGI}->param('Email'). "\n".
      "X-mailer: ". "request-mailer.pl <".
        $self->{CGI}->param("CallerURL"). ">\n".
      "X-Remote-Host: $ENV{'REMOTE_HOST'} ($ENV{'REMOTE_ADDR'})\n".
      "X-Remote-User: $ENV{'REMOTE_USER'}\n".
      "Subject: ". $self->{CGI}->param('MailSubject'). "\n".
      "\n".                     # separate headers from the body
      $mailMessage;
    $mailer->datasend($mailMessage);
    $mailer->dataend;
  }
  else
  {
    $self->Error("Mailer error");
    $self->ErrorDescription($mailer->message());
    $self->ReportError();
    exit;
  }
  
  $mailer->quit;
}


# ReportSuccess
#   Report successful completion of the form.
#
sub ReportSuccess
{
  my $self= shift;
  my $successReport= "";
  my $message= "Here's a copy of your request:<br>\n" .
    "<blockquote><pre>" .
    $self->Message() .
    "</pre></blockquote>";

  if ($self->ReportHeader())
  {
    $successReport= $self->CreateReport($self->SuccessHeader() . $message);
  }

  if ($successReport)
  {
    print $self->{CGI}->header();
    print $successReport;
  }
  else
  {
    print
      $self->{CGI}->header(),
      $self->{CGI}->start_html('Success message: Request sent'),
      $self->SuccessHeader(),
      $message,
      $self->SuccessFooter(),
      $self->{CGI}->end_html;
  }
}


# Successheader
#   Text which initiates our success report.
#
sub SuccessHeader
{
  my $self= shift;
  my $text= "";
  my $successNote= "<p>You will hear back from a human soon.</p>\n";

  # Overwrite with optional field if defined; keep the default value
  # for backward compatibility with versions prior to 1.1.1
  $successNote= $self->{CGI}->param('SuccessNote')
    if $self->{CGI}->param('SuccessNote');

  $text=  $self->{CGI}->h3('Success!')
    . "<p>I sent your request to \n"
    . "<a href=\"mailto:". $self->MailToAddress(). "\">"
    . $self->{CGI}->param('OperatorName'). "</a>, \n"
    . "along with a copy to you.</p>\n"
    . $successNote;

  return $text;
}


# SuccessFooter
#   Text which terminates our success report.
#   Originally meant to generate the return pointer (thus the code).
#
sub SuccessFooter
{
  my $self= shift;
  my $pointerAddress= $self->{CGI}->param('CallerURL');
  my $pointerText= $self->{CGI}->param('CallerTitle');
  my $text= "";

  return $text unless $pointerAddress;

  $pointerText= $pointerAddress unless $pointerText;

  $text .= "<center><a href=\"$pointerAddress\">";
  $text .= "Return to $pointerText...";
  $text .= "</a></center>\n";

  return $text;
}


# ConfirmEmailAddress
#   Confirms the argument is a valid email address syntax.
#
sub ConfirmEmailAddress
{
  my $self= shift;
  my $address;                  # the complete email address
  my $user;                     # the username part of the email address
  my $mailhost;         # the host part of the email address
  my $confirmed;                # boolean indicating address validity
  my $smtp;                     # the SMTP object
  my $dns;                      # the DNS object
  my @mx;                       # MX records for the mailhost
  my $a;                        # A records for the mailhost
  my @hosts;                    # an ordered array of MX and A results
  my $rr;                       # DNS result records
  my $host;                     # hosts we'll try
  my $lastPreference;           # keeps track of mail exchanger preferences
  my $errorMessage;             # a descriptive error message

  $self->Error("E-mail address error");

  $address= $self->{CGI}->param('Email');
  ($user)= split(/[!%@]/, $address);
  $address=~ /^$user[!%@](.+)$/;
  $mailhost= $1;

  if ($user eq "")
  { # Should never get here, but the address is blank!
    $self->ErrorDescription("Your email address is missing.");
    $self->ReportError();
    exit;
  }
  unless ($user =~ /^([\-\+\w\d\._]+)$/)
  { # Some illegitimate characters within the user name
    $self->ErrorDescription("Bad user-id format: [$user].");
    $self->ReportError();
    exit;
  }

  # First, find all the lowest priority MX hosts
  #   if none exist, find all the A records for the host
  if ($mailhost)
  { # We have a fully qualified address -- check DNS
    $host= $mailhost;

    $dns= new Net::DNS::Resolver;
    if (@mx= mx($dns, $host))
    {                   # found at least one mail exchange record
      # Peg initial preference high for lowest preference comparisons
      $lastPreference= 1000000;
      foreach $rr (@mx)
      {                 # keep each lowest preference MX name
        last if ($lastPreference < $rr->preference);
        $lastPreference=  $rr->preference;
        push(@hosts, $rr->exchange);
      }
    }
    else
    {
      $a= $dns->query($host, "A");
      if ($a)
      {                 # found at least one address record
        foreach $rr ($a->answer)
        {                       # keep each address
          push(@hosts,  $rr->address) if ($rr->type eq "A");
        }
      }
    }
    unless (@hosts)
    { # Hmm, cannot resolve supplied domain
      $self->Error("DNS error");
      $self->ErrorDescription
        ("Could not resolve [$host] for address confirmation.");
      $self->ReportError();
      exit(0);
    }

    # Having either list, attempt delivery to supplied email address
    #   for each host name (MX) or host address (A)
    foreach $host (@hosts)
    {
      if ($smtp= new Net::SMTP($host, Timeout => 300))
      {
        $smtp->mail($self->MailToAddress());
        $confirmed= $smtp->to($address);
        $smtp->quit();
      }
      last if $confirmed;
    }
  }
  else
  { # Try local delivery for unqualified addresses
    if ($smtp= new Net::SMTP())
      {
        $address= $user . "\@" . $smtp->domain();
        $smtp->mail($self->MailToAddress());
        $confirmed= $smtp->to($address);
        $smtp->quit();
      }
  }

  # In case of failure, report such with the list of tried
  #   host names (MX) or host addresses (A) and the final error message
  #   from Net::SMTP
  unless ($confirmed)
  {
    $errorMessage= "Could not confirm [$address] via ";
    if (@hosts)
    { # List all hosts contacted
      $errorMessage.= "[" . join(",", @hosts) . "]";
    }
    else
    { # We only tried the local server
      $errorMessage.= "the local server";
    }
    if ($@)
    {                   # include the error message from Net::SMTP
      $errorMessage.= " ($@).";
    }
    else
    {
      $errorMessage.= ".";
    }
    $self->ErrorDescription($errorMessage);
    $self->ReportError();
    exit;
  }

  return $address;
}


#
# Required termination
#
1;