#!/usr/bin/perl
use Socket;

sub OutputError;
sub OutputLoginPage;
sub OutputHeader;
sub OutputFooter;
sub LoginToPOPServer;
sub QueryServer;
sub GetMessageInfo;
sub HTMLize;
sub OutputMessageInfo;
sub OutputMessage;
sub DeleteMessage;
sub OutputMessageForm;
sub SendMessage;
sub ReadConfig;
sub InterpolateVariables;
sub HideString;
sub UnhideString;
sub OSSettings;
sub ReadParse;

############################################################################
# This script is used to generate many different individual web pages, and
# invoked separately at several different points in the process.  These
# possible points are:
#
# 1) Initially: query string is null.  This script generates a login page.
# 2) Login: the login page calls this script to do the mail check.
# 3) Reply: this script is invoked to reply to a message (or a forward).
# 4) Send: this script is invoked to send a new message.
#
# This section of the program is used to determine what behavior this 
# individual invocation of the script is to be responsible for, based
# upon the query string.
############################################################################

# Do anything that is OS-specific.
OSSettings();

# Set this to TRUE if your Perl interpreter supports "alarm".  As of this
# Writing, NT Perl does not.  If this is not set, Mail will not be able
# to timeout when a server hangs.  The OSSettings() routine will attempt
# to set this variable, but you can override it here if you want.
# $UseAlarm = TRUE;

# Retrieve some important variables to make them easier to use.
ReadParse();
$login = UnhideString($in{"LOGIN"});
$hidden_login = HideString($login);
$password = UnhideString($in{"PASSWORD"});
$hidden_password = HideString($password);
$server = UnhideString($in{"SERVER"});
$hidden_server = HideString($server);

$card_number = 1;


# Read the configuration file.
ReadConfig();

# Find a URL to this script so that Mail can call itself.
$Me = $ENV{SCRIPT_NAME};
unless($Me =~ /^\//){ $Me = "/$Me"; } # Make sure it's rooted.

# First check for orders from a form, from a previous instance of mailman.
if($in{"MAILMAN_LOGIN"})
{
    QueryServer();
    exit(0);
}
# If this is the result of a message display subform.
elsif($in{"MAILMAN_DISPLAY"})
{
    OutputMessage($in{"ID"});
    exit(0);
}
# If this is the result of a message delete subform.
elsif($in{"MAILMAN_DELETE"})
{
    DeleteMessage($in{"ID"});
    exit(0);
}
# If this is the result of a new message subform.
elsif($in{"MAILMAN_NEW"})
{
    OutputMessageForm("NEW",0,0);
    exit(0);
}
# If this is the result of a reply subform.
elsif($in{"MAILMAN_REPLY"})
{
    OutputMessageForm($in{"ID"},0,0);
    exit(0);
}
# If this is the result of a reply all subform.
elsif($in{"MAILMAN_REPLYALL"})
{
    OutputMessageForm($in{"ID"},TRUE,0);
    exit(0);
}
# If this is the result of a forward subform.
elsif($in{"MAILMAN_FORWARD"})
{
    OutputMessageForm($in{"ID"},0,TRUE);
    exit(0);
}
# If this is the result of a forward subform.
elsif($in{"MAILMAN_SEND"})
{
    SendMessage();
    exit(0);
}
# This is a new login.
else
{
	# If not all info is present, the login page must be presented
	# instead of simply querying the server.
	if($login && $password && $server)
	{
	    QueryServer();
	    exit(0);
	}

    # If there is not a query string, and no configuration file, 
    # or if there is no password in the configuration file,
    # then display the login page.
    OutputLoginPage();
    exit(0);
}

# A general-purpose routine used to produce error message pages.
sub OutputError
{
    my($error_message) =  @_;

    # If there is no parameter, then this routine was called 
    # by the system as a timeout, so use the preset timeout message
    if($error_message eq "ALRM")
    {
	if($UseAlarm eq TRUE){ alarm(0); }
	$error_message = "$timeout_message";

	# Finish the session gracefully.
	print SOCKET "QUIT\n";
	close SOCKET;
    }

    # Produce the standard header.
    OutputHeader("MailMan Error: $error_message");

    # Print the actual error.
    print "<b>$error_message</b><br/>";

    # Produce the standard footer.
    OutputFooter();

    # Quit the program.
    exit(1);
}

# Routine used to produce a user login page.
sub OutputLoginPage
{
    # Produce the standard header.
    OutputHeader("MailMan Login");
    
    # Interpolate variables into the template.
    $HTMLLoginInterpolated = InterpolateVariables($HTMLLogin,
        '<LOGIN>'=>$login,
        '<PASSWORD>'=>$password,
        '<SERVER>'=>$server);

    # Print the template.
    print $HTMLLoginInterpolated;

    # Product the standard footer.
    OutputFooter();
}

# This produces the HTML declaration for the server, plus a standard
# header from a file, or a default header if there is no file found.
sub OutputHeader
{
    my($title,$extra) = @_;

    # Only do this once.
    if($OutputHeaderUsed++) { return; }

    # No buffering on the output.
    $|=1;

    # Instruct everybody downstream not to cache this document.
#    print "Pragma: no-cache\n";
#    print "Expires: Fri, 01 Jan 1983 00:00:00 GMT\n";

    # Declare that this is HTML code.
    print "Content-Type: text/vnd.wap.wml\n\n";

    # Spit out any extra headers that might be wanted.
    print "\n$extra\n";

    # Print the template.
    print InterpolateVariables($HTMLHeader,
        '<PAGE_TITLE>',$title);
}

# Just like OutputHeader, but at the bottom of the page.
sub OutputFooter
{
    # Only do this once.
    if($OutputFooterUsed++) { return; }

    print $HTMLFooter;
}

# This routine deals with the details of loggin in to a POP server.
sub LoginToPOPServer
{
    # Make sure that there is enough information to proceed.
    unless($login)
    {
        OutputError("No login provided, cannot proceed.");
    }
    unless($password)
    {
        OutputError("No password provided, cannot proceed.");
    }
    unless($server)
    {
        OutputError("No server provided, cannot proceed.");
    }

    # Set up a timeout for this operation.
    if($UseAlarm eq TRUE)
    {
        $timeout_message = "Connection to server timed out.";
        $SIG{'ALRM'} = \&OutputError;
        alarm(180);
    }

    # Attempt to open a socket to the POP3 server.
    $protocol = getprotobyname('tcp');
    socket(SOCKET,PF_INET,SOCK_STREAM,$protocol);
    $remote_ip = gethostbyname($server);
    $remote_sock = pack('Sna4x8', AF_INET, 110, $remote_ip);
    unless(connect(SOCKET, $remote_sock))
    {
	    OutputError("Could not connect to server \"$server\"");
    }

    # No buffering on the socket.
    select(SOCKET); $|=1; select(STDOUT);

    # Set up the next timeout.
    $timeout_message = "The server connected, but will not respond.";
    if($UseAlarm eq TRUE){ alarm(180); }

    # Check to make sure that it looks like a POP3 server, 
    # according to RFC 1725.
    unless(<SOCKET> =~ /\+OK/)
    {
	    OutputError("The server does not respond appropriately.");
    }

    # Reset the timeout clock.
    $timeout_message = "The server timed out during login.";
    if($UseAlarm eq TRUE){ alarm(180); }

    # Send the user name.
    print SOCKET "USER $login\n";
    $return = <SOCKET>;
    unless($return =~ /\+OK/)
    {
	    OutputError("Server Error: \"$return\"");
    }

    print SOCKET "PASS $password\n";
    $return = <SOCKET>;
    unless($return =~ /\+OK/)
    {
	    OutputError("Server Error: \"$return\"");
    }

    # Get a list from the server.
    print SOCKET "LIST\n";
    $return = <SOCKET>;
    unless($return =~ /\+OK/)
    {
        OutputError("Server Error: \"$return\"");
    }
    $MessageNumber = 0;
    while(<SOCKET> =~ /(\d+) (\d+)/)
    {
        $MessageSize[$1] = $2;
	$MessageNumber ++;
    }
}

# This routine does the real work of connecting to the specified server.
sub QueryServer
{ 
    # Do the server login with the details provided.
    LoginToPOPServer();

    # Produce the standard header.
    OutputHeader("Mailman: $login\@$server", "");

    # Produce some output for starters.
    print InterpolateVariables($HTMLMessagesHeader,
        '<MESSAGE_NUMBER>'=>$MessageNumber,
        '<LOGIN>'=>$login,
        '<SERVER>'=>$server,
        '<HIDDEN_LOGIN>'=>$hidden_login,
        '<HIDDEN_PASSWORD>'=>$hidden_password,
        '<HIDDEN_SERVER>'=>$hidden_server);

    # Reset the timeout clock.
    $timeout_message = "The server timed out during message listing.";
    if($UseAlarm eq TRUE){ alarm(180); }

    # Get a list from the server.
    print SOCKET "LIST\n";
    $return = <SOCKET>;
    unless($return =~ /\+OK/)
    {
        OutputError("Server Error: \"$return\"");
    }
    $MessageNumber = 0;
    while(<SOCKET> =~ /(\d+) (\d+)/)
    {
        $MessageSize[$1] = $2;
	$MessageNumber ++;
    }
    
    # Cycle through the message list again, producing output.
    for($index=0;$index<$MessageNumber;$index++)
    {
        GetMessageInfo($index+1);
		
		$card_number++;
		print qq!<br/><b><a href="#msg! . $card_number . qq!">Next</a></b></p></card><card id="msg! . $card_number . qq!" title="CIHS"><p align="left">!;
		
        OutputMessageInfo($index+1);
    }

    # Finish the session gracefully.
    print SOCKET "QUIT\n";

    # Produce the messages footer.
    print $HTMLMessagesFooter;

    # Produce the standard footer.
    OutputFooter();
}

sub GetMessageInfo
{
    my($message) =  @_;

    # Reset the timeout clock.
    $timeout_message = "The server timed out fetching a header.";
    if($UseAlarm eq TRUE){ alarm(10); }

    # Get a list from the server.
    print SOCKET "TOP $message 0\n";
    $return = <SOCKET>;
    unless($return =~ /\+OK/)
    {
	OutputError("Server Error: \"$return\"");
    }
    $To = "";
    $Cc = "";
    $From = "";
    $Date = "";
    $Subject = "";
    $ReplyTo = "";
    $ID = "";
    while(<SOCKET>)
    {
        if(/^\.\r$/){ last; }
        if(/^To\: (.+)\r$/)
        {
            $To = $1;
        }
        if(/^[cC][cC]\: (.+)\r$/)
        {
            $Cc = $1;
        }
        if(/^From\: (.+)\r$/)
        {
            $From = $1;
        }
        if(/^Date\: (.+)\r$/)
        {
            $Date = $1;
        }
        if(/^Subject: (.+)\r$/)
        {
            $Subject = $1;
        }
        if(/^Reply-To: (.+)\r$/)
        {
            $ReplyTo = $1;
        }
        $ID .= $_;
    }

    # Finish creating message info field, which is a 
    # fixed-length hash string.
    # Shorten the ID without throwing away any data.
    while(length($ID)>20)
    {
        $ID = (substr($ID,0,20) ^ substr($ID,20));
    }
    $ID = pack("u*",$ID);
    $ID =~ s/(\W)/sprintf("%%%x", ord($1))/eg;

    # Clean up.
    unless($To){ $To = "Unknown";}
    unless($From){ $From = "Unknown";}
    unless($Date){ $Date = "Unknown";}
    unless($Subject){ $Subject = "Unspecified";}
    unless($ID){ $ID = "0";}

    # Next/Prev
    $PreviousID[$message+1] = $ID;
    $NextID[$message-1] = $ID;

    # Make these HTML-safe.
    $HTMLTo = HTMLize($To);
    $HTMLCc = HTMLize($Cc);
    $HTMLFrom = HTMLize($From);
    $HTMLSubject = HTMLize($Subject);
}

# This routine takes a string and makes it safe for display in HTML
# by escaping out "<", ">", and "&";
sub HTMLize
{
    my($string) = @_;

    # Detect email addresses. 
    # (Escape the produced "<" and ">" characters to protect them.)
    $string =~
    s/([^\s\<]+\@[^\s\r\,\;\>]+)/\%lta href\=\"mailto\:$1\"\%gt$1\%lt\/a\%gt/g;

    $string =~ s/\&/\&amp;/g;
    $string =~ s/\</\&lt;/g;
    $string =~ s/\>/\&gt;/g;

    # Un-escape the "<" and ">" characters from the email URLs.
    $string =~ s/\%lt/\</g;
    $string =~ s/\%gt/\>/g;

    # URLs.
    $string =~ s/(http\:\S+)\s/\<a href\=\"$1\"\>$1\<\/a\>/g;

    return $string;
}

sub OutputMessageInfo
{
    my($message) =  @_;
	
    # Once a source and date are known, print them.

    print InterpolateVariables($HTMLMessageInfo,
        '<ID>'=>$ID,
        '<SUBJECT>'=>$HTMLSubject,
        '<SIZE>'=>$MessageSize[$message],
        '<FROM>'=>$HTMLFrom,
        '<DATE>'=>$Date,
        '<MESSAGE_NUMBER>'=>$MessageNumber,
        '<LOGIN>'=>$login,
        '<SERVER>'=>$server,
        '<HIDDEN_LOGIN>'=>$hidden_login,
        '<HIDDEN_PASSWORD>'=>$hidden_password,
        '<HIDDEN_SERVER>'=>$hidden_server);
}

sub OutputMessage
{
    my($message_id) =  @_;

    # Do the server login with the details provided.
    LoginToPOPServer();

    # Produce the standard header.
    OutputHeader('MailMan Message', "");

    # Reset the timeout clock.
    $timeout_message = "The server timed out during message listing.";
    if($UseAlarm eq TRUE){ alarm(180); }

    # Get a list from the server.
    print SOCKET "LIST\n";
    $return = <SOCKET>;
    unless($return =~ /\+OK/)
    {
	OutputError("Server Error: \"$return\"");
    }
    $MessageNumber = 0;
    while(<SOCKET> =~ /(\d+) (\d+)/)
    {
	$MessageSize[$1] = $2;
	$MessageNumber ++;
    }
    
    # Cycle through the message list, finding headers.
    $MessageFound = 0;
    for($index=0;$index<$MessageNumber;$index++) {
		GetMessageInfo($index+1);
		
		# Check to see if the right message has been found.
		#if($ID eq $message_id || URI::Escape->uri_unescape($ID) eq $message_id) { 
		if(unescapeURL($ID) eq unescapeURL($message_id)) { 
			$message_id = $ID;
			$MessageFound = TRUE;
			last;
		}
    }

    # Get the next message header to find out what the ID is, for
    # a "Next" button.
    if($index+1<$MessageNumber && $MessageFound)
    {
	GetMessageInfo($index+2);

	# Re-fetch the current header.
	GetMessageInfo($index+1);
    }

    # Insert a CC field if there are Cc components.
    if($Cc)
    {
        $HTMLCCRow = "<b>CC:</b> $HTMLCc<br>\n";
    }

    # Prepare prev/next buttons.
    $prevbutton = $nextbutton = "";
    if($PreviousID[$index+1])
    {
	    $prevbutton = qq|<input type="submit" name="SHOW:$PreviousID[$index+1]" value="Previous Message">|;
    }
    if($NextID[$index+1])
    {
        $nextbutton = qq|<input type="submit" name="SHOW:$NextID[$index+1]" value="Next Message">|;
    }

	
    # If a message was found, spit it out.
    if($MessageFound)
    {
        print InterpolateVariables($HTMLMessageHeader,
            '<ID>'=>$ID,
            '<TO>'=>$HTMLTo,
            '<FROM>'=>$HTMLFrom,
            '<DATE>'=>$Date,
            '<SUBJECT>'=>$HTMLSubject,
            '<CC>'=>$HTMLCCRow,
            '<PREVBUTTON>'=>$prevbutton,
            '<NEXTBUTTON>'=>$nextbutton,
            '<HIDDEN_LOGIN>'=>$hidden_login,
            '<HIDDEN_PASSWORD>'=>$hidden_password,
            '<HIDDEN_SERVER>'=>$hidden_server);

        # Reset the timeout clock.
        $timeout_message = "The server timed out retrieving a message.";
        if($UseAlarm eq TRUE){ alarm(180); }

        # Fetch the actual message.
        $pop_index = $index+1;
        print SOCKET "RETR $pop_index\n";
        unless($return =~ /\+OK/)
        {
            OutputError("Server Error: \"$return\"");
        }

        $PastHeader=0;
        while(<SOCKET>)
        {
            if(/^\.\r$/){ last; }
            if($PastHeader)
            { 
                # Make HTML-safe.
                $safe_string = HTMLize($_);

                # Wrap big lines, but not unless they really need it.
                $safe_string =~ s/(.{1,86})\s+/$1\n/g;

                # The CR/LF vs LF thing.
                $safe_string =~ s/\r//g;

                print $safe_string;
            }
            if(/^\s$/){ $PastHeader=TRUE; }
        }

    }
    else
    {
        OutputError("Could not find the specified message.");
    }

    # Finish the session gracefully.
    print SOCKET "QUIT\n";

#    print $HTMLMessageFooter;
	print InterpolateVariables($HTMLMessageFooter,
            '<ID>'=>$ID,
            '<TO>'=>$HTMLTo,
            '<FROM>'=>$HTMLFrom,
            '<DATE>'=>$Date,
            '<SUBJECT>'=>$HTMLSubject,
            '<CC>'=>$HTMLCCRow,
            '<PREVBUTTON>'=>$prevbutton,
            '<NEXTBUTTON>'=>$nextbutton,
            '<HIDDEN_LOGIN>'=>$hidden_login,
            '<HIDDEN_PASSWORD>'=>$hidden_password,
            '<HIDDEN_SERVER>'=>$hidden_server);

    # Produce the standard footer.
    OutputFooter();
}

sub DeleteMessage
{
    my($message_id) =  @_;

    # Do the server login with the details provided.
    LoginToPOPServer();

    # Reset the timeout clock.
    $timeout_message = "The server timed out during message listing.";
    if($UseAlarm eq TRUE){ alarm(180); }

    # Get a list from the server.
    print SOCKET "LIST\n";
    $return = <SOCKET>;
    unless($return =~ /\+OK/)
    {
        OutputError("Server Error: \"$return\"");
    }
    $MessageNumber = 0;
    while(<SOCKET> =~ /(\d+) (\d+)/)
    {
        $MessageSize[$1] = $2;
	$MessageNumber ++;
    }
    
    # Cycle through the message list, finding headers.
    $MessageFound = 0;
    for($index=0;$index<$MessageNumber;$index++)
    {
        GetMessageInfo($index+1);
	
        # Check to see if the right message has been found.
        if($ID eq $message_id) { $MessageFound = TRUE; last; }
    }

    # Reset the timeout clock.
    $timeout_message = "The server timed out deleting a message.";
    if($UseAlarm eq TRUE){ alarm(180); }

    # If a message was found, spit it out.
    if($MessageFound)
    {
        $pop_index = $index+1;
        print SOCKET "DELE $pop_index\n";

        $return = <SOCKET>;
        unless($return =~ /\+OK/)
        {
            OutputError("Server Error: \"$return\"");
        }
    }

    # Finish the session gracefully.
    print SOCKET "QUIT\n";

    # Go back to the beginning and produce some output.
    QueryServer();
}

sub OutputMessageForm
{
    my($message_id,$reply_all,$forward) =  @_;

    # Produce the standard header.
    OutputHeader('MailMan Message Form');

    if($message_id ne "NEW")
    {
        # Do the server login with the details provided.
        LoginToPOPServer();

        # Reset the timeout clock.
        $timeout_message = "The server timed out during message listing.";
        if($UseAlarm eq TRUE){ alarm(180); }

        # Get a list from the server.
        print SOCKET "LIST\n";
        $return = <SOCKET>;
        unless($return =~ /\+OK/)
        {
            OutputError("Server Error: \"$return\"");
        }
        $MessageNumber = 0;
        while(<SOCKET> =~ /(\d+) (\d+)/)
        {
            $MessageSize[$1] = $2;
	    $MessageNumber ++;
        }
    
        # Cycle through the message list, finding headers.
        $MessageFound = 0;
        for($index=0;$index<$MessageNumber;$index++)
        {
            GetMessageInfo($index+1);
	
            # Check to see if the right message has been found.
            if($ID eq $message_id) { $MessageFound = TRUE; last; }
        }

        # Set the header lines appropriately.
        $OriginalTo = $To;
        $OriginalSubject = $Subject;
        if($ReplyTo)
        {
            $To = $ReplyTo;
        }
        else
        {
            $To = $From;
        }
        if($reply_all)
        {
            $To .= ", $OriginalTo";
	    
            # Also anybody that got CC'd originally.
            if($Cc){ $To .= ", $Cc"; }
        }
        if($forward)
        {
            unless($Subject =~ /^[Ff]wd\:/){ $Subject = "Fwd: $Subject"; }
            $To = "";
        }
        else
        {
            unless($Subject =~ /^[Rr]e\:/){	$Subject = "Re: $Subject"; }
        }
    }

    # Make sure that there is a name to display.
    unless($name){ $name = "$login\@$server"; }

    # Clean up the "To", "From" and "Subject" lines to make them safe.
    $To =~ s/\"//g;
    $Subject =~ s/\"//g;
    $name =~ s/\"//g;

    # If a message was found, spit it out.
    if($MessageFound || ($message_id eq "NEW"))
    {
        print InterpolateVariables($HTMLSendMessageHeader,
            '<HIDDEN_LOGIN>'=>$hidden_login,
            '<HIDDEN_PASSWORD>'=>$hidden_password,
            '<HIDDEN_SERVER>'=>$hidden_server,
            '<TO>'=>$To,
            '<CC>'=>$cc,
            '<FROM>'=>$name,
            '<SUBJECT>'=>$Subject,
	    '<OUTGOING>'=>$outgoing);

        if($message_id ne "NEW")
        {
            # Reset the timeout clock.
            $timeout_message = "The server timed out retrieving a message.";
            if($UseAlarm eq TRUE){ alarm(180); }

            # Fetch the actual message.
            $pop_index = $index+1;
            print SOCKET "RETR $pop_index\n";
            unless($return =~ /\+OK/)
            {
                OutputError("Server Error: \"$return\"");
            }
	
            # Insert the user's signature if one was specified (forwards).
            if($forward)
            {
                print $signature;

                print InterpolateVariables($HTMLForwardHeader,
                    '<FROM>'=>$From,
                    '<ORIGINAL_TO>'=>$OriginalTo,
                    '<DATE>'=>$Date,
                    '<ORIGINAL_SUBJECT>'=>$OriginalSubject);
            }
	    
            $PastHeader=0;
	    while(<SOCKET>)
	    {
	        if(/^\.\s$/){ last; }
		if($PastHeader)
		{ 
		    # The CR/LF vs LF thing.
		    s/\r//g;

        	    print "> $_"; 
        	}
        	if(/^\s$/){ $PastHeader=TRUE; }
            }
        }

        # Insert the user's signature if one was specified (replies).
        if(!$forward)
        {
            print "\n$signature";
        }

        print InterpolateVariables($HTMLSendMessageFooter,
            '<ID>'=>$ID);
    }
    else
    {
        OutputError("Could not find the specified message.");
    }

    # Finish the session gracefully.
    if($message_id ne "NEW"){ print SOCKET "QUIT\n"; }

    # Produce the standard footer.
    OutputFooter();    
}

sub SendMessage
{
    # Find the SMTP server name.
    $server = $in{"OUTGOING"};
    unless($server)
    {
        OutputError("No server provided, cannot proceed.");
    }

    # Attempt to open a socket to the SMTP server.
    $protocol = getprotobyname('tcp');
    socket(SOCKET,PF_INET,SOCK_STREAM,$protocol);
    $remote_ip = gethostbyname($server);
    $remote_sock = pack('Sna4x8', AF_INET, 25, $remote_ip);
    unless(connect(SOCKET, $remote_sock))
    {
        OutputError("Could not connect to server.");
    }

    # No buffering on the socket.
    select(SOCKET); $|=1; select(STDOUT);

    # Set up the next timeout.
    $timeout_message = "The server connected, but will not respond.";
    if($UseAlarm eq TRUE){ alarm(180); }

    # Check to make sure that it looks like an SMTP server, 
    # according to RFC 821.
    $return = <SOCKET>;
    unless($return =~ /^220.+/)
    {
        OutputError("The server does not respond appropriately.");
    }

    # Get the whole reply, in case it's multi-line.
    while($return =~ /^\d\d\d\-/)
    {
	$return = <SOCKET>;
    }

    # Send a greeting, using the client's machine name.
#    print SOCKET "HELO $ENV{REMOTE_HOST}\r\n";
    print SOCKET "HELO $server\r\n";
    $return = <SOCKET>;
    unless($return =~ /^250.+/)
    {
        OutputError("Server Error: \"$return\"");
    }

    # Get the whole reply, in case it's multi-line.
    while($return =~ /^\d\d\d\-/)
    {
	$return = <SOCKET>;
    }

    # Reset the timeout clock.
    $timeout_message = "The server timed out while accepting a message.";
    if($UseAlarm eq TRUE){ alarm(180); }

    # Send the source name.
    print SOCKET "MAIL FROM: <>\r\n";
    $return = <SOCKET>;
    unless($return =~ /^250.+/)
    {
        OutputError("Server Error: \"$return\"");
    }

    # Get the whole reply, in case it's multi-line.
    while($return =~ /^\d\d\d\-/)
    {
	$return = <SOCKET>;
    }

    # Send each recipient.
    $in{"TO"} =~ s/\;/\,/g; # Allow ";"s to divide addresses.
    $all_recipients = $in{"TO"};
    if($in{"CC"}){ $all_recipients .= qq|,$in{"CC"}|; }
    @Recipients = split(/[\,]/,$all_recipients);
    while($recipient = shift(@Recipients))
    {
        if($recipient =~ /([^\s<]+@[^\s\r,>]+)/)
        {
	    $recipient = '<' . $1 . '>';
            print SOCKET "RCPT TO: $recipient\r\n";
            $return = <SOCKET>;
            unless($return =~ /^250.+/)
            {
                OutputError("Server Error: \"$return\"");
            }

	    # Get the whole reply, in case it's multi-line.
	    while($return =~ /^\d\d\d\-/)
	    {
		$return = <SOCKET>;
	    }
	}
    }

    print SOCKET "DATA\n";
    $return = <SOCKET>;
    unless($return =~ /^354.+/)
    {
        OutputError("Server Error: \"$return\"");
    }

    # Get the whole reply, in case it's multi-line.
    while($return =~ /^\d\d\d\-/)
    {
	$return = <SOCKET>;
    }

    # Build an RFC 822 date.
    @days = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
    @months = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
    $wday = $days[$wday];
    $mon = $months[$mon];
    $hour = sprintf("%2.2d",$hour);
    $min = sprintf("%2.2d",$min);
    $sec = sprintf("%2.2d",$sec);
    $datestr = "$wday, $mday $mon $year $hour:$min:$sec +0000";

    # Build the message header.
    $Message = qq|To: $in{"TO"}\r\n|;
    if($in{"CC"}){ $Message .= qq|Cc: $in{"CC"}\r\n|; }
    $Message .= qq|From: $in{"FROM"}\r\n|;
    $Message .= qq|Subject: $in{"SUBJECT"}\r\n|;
    $Message .= qq|Date: $datestr\r\n|;
    $Message .= "X-Mailer: Endymion MailMan v1.1\r\n";
    $Message .= "X-Mailer-Info: http://www.endymion.com/portfolio/software/scripts/mailman.htm\r\n";
    $Message .= "\r\n";

    # The message itself.
    $Message .= $in{"TEXT"};

    # Clean up after DOS, if necessary.
    # $Message =~ s/\r\n?/\n/g;

    print SOCKET $Message;

    # Terminate the message.
    print SOCKET "\r\n.\r\n";
    $return = <SOCKET>;
    unless($return =~ /^250.+/)
    {
        OutputError("Server Error: \"$return\"");
    }

    # Get the whole reply, in case it's multi-line.
    while($return =~ /^\d\d\d\-/)
    {
	$return = <SOCKET>;
    }

    # Finish the connection.
    print SOCKET "QUIT\r\n";

    # Close connection.
    close SOCKET;

    # Produce a response message.
    OutputHeader('MailMan Message Sent', "");

    print InterpolateVariables($HTMLSendAck,
        '<HIDDEN_LOGIN>'=>$hidden_login,
        '<HIDDEN_PASSWORD>'=>$hidden_password,
        '<HIDDEN_SERVER>'=>$hidden_server);

    OutputFooter();

    # End gracefully.
    exit(0);
}

############################################################################
# Password Obfuscation:
# Since some browsers and proxy servers may not pay the proper attention
# to 'Don't Cache' directives (MSIE comes to mind) and since this script
# may not always be run through SSL, an effort is made here to obscure
# passwords.  This is obviously very weak as encryption goes, but it's
# better than simply transmitting the passwords in cleartext.  If you
# are concerned about using stronger encryption for protecting passwords,
# then you can easily drop your better encryption package in by modifying
# these two functions.  The only requirement for replacement functions
# is that UnhideString must be able to recognize cleartext and return
# it unmodified.  This implementation of UnhideString does this by looking
# for a signature tag of "%%%%" at the beginning and end of a cipher string.
############################################################################

# Build a key which will be unique for the host/server pair, but
# Will always be the same for that pair.  You specify your own length.
sub ConnectionKey
{
    my($desired_length) = @_;

    $FirstPart = crypt($ENV{SERVER_NAME},42);
    $SecondPart = crypt($ENV{REMOTE_HOST},69);

    # Trim the key into the proper length and return it.
    $key = $FirstPart ^ $SecondPart;
    if(length($key)==$desired_length)
    {
	return($key);
    }
    elsif(length($key)>$desired_length)
    {
	return(substr($key,0,$desired_length));
    }
    else
    {
	while(length($key)<$desired_length)
	{
	    $key = "$key$key";
	}
	return(substr($key,0,$desired_length));
    }
}

sub ReadConfig
{
    # If there is a configuration file, use it for login information.
    if(open(CONFIG,"<mail.ini"))
    {
        while(<CONFIG>)
        {
            if(/^LOGIN\=(.*)$/)
            {
                $login = $1 unless $login;
                $hidden_login = HideString($login);
            }
            elsif(/^PASSWORD\=(.*)$/)
            {
                $password = $1 unless $password;
                $hidden_password = HideString($password);
            }
            elsif(/^SERVER\=(.*)$/)
            {
                $server = $1 unless $server;
                $hidden_server = HideString($server);
            }
            elsif(/^OUTGOING\=(.*)$/)
            {
                $outgoing = $1;
            }
            elsif(/^NAME\=(.*)$/)
            {
                $name = $1;
            }
            elsif(/^CC\=(.*)$/)
            {
                $cc = $1;
            }
            elsif(/^SIGNATURE_BEGIN/)
            {
                SignatureLoop: while(<CONFIG>)
                {
                    if(/^SIGNATURE_END$/){ last SignatureLoop; }
                    else
                    {
                        $signature .= $_;
                    }
                }
            }
            elsif(/^HEADER_BEGIN/)
            {
                $HTMLHeader = "";
                header_loop: while(<CONFIG>)
                {
                    if(/^HEADER_END/){ last header_loop; }
                    else
                    {
                        $HTMLHeader .= $_;
                    }
                }
            }
            elsif(/^FOOTER_BEGIN/)
            {
                $HTMLFooter = "";
                footer_loop: while(<CONFIG>)
                {
                    if(/^FOOTER_END/){ last footer_loop; }
                    else
                    {
                        $HTMLFooter .= $_;
                    }
                }
            }
            elsif(/^LOGIN_BEGIN/)
            {
                $HTMLLogin = "";
                login_loop: while(<CONFIG>)
                {
                    if(/^LOGIN_END/){ last login_loop; }
                    else
                    {
                        $HTMLLogin .= $_;
                    }
                }
            }
            elsif(/^MESSAGES_HEADER_BEGIN/)
            {
                $HTMLMessagesHeader = "";
                messages_header_loop: while(<CONFIG>)
                {
                    if(/^MESSAGES_HEADER_END/){ last messages_header_loop; }
                    else
                    {
                        $HTMLMessagesHeader .= $_;
                    }
                }
            }
            elsif(/^MESSAGES_FOOTER_BEGIN/)
            {
                $HTMLMessagesFooter = "";
                messages_footer_loop: while(<CONFIG>)
                {
                    if(/^MESSAGES_FOOTER_END/){ last messages_footer_loop; }
                    else
                    {
                        $HTMLMessagesFooter .= $_;
                    }
                }
            }
            elsif(/^MESSAGE_INFO_BEGIN/)
            {
                $HTMLMessageInfo = "";
                message_info_loop: while(<CONFIG>)
                {
                    if(/^MESSAGE_INFO_END/){ last message_info_loop; }
                    else
                    {
                        $HTMLMessageInfo .= $_;
                    }
                }
            }
            elsif(/^MESSAGE_HEADER_BEGIN/)
            {
                $HTMLMessageHeader = "";
                message_header_loop: while(<CONFIG>)
                {
                    if(/^MESSAGE_HEADER_END/){ last message_header_loop; }
                    else
                    {
                        $HTMLMessageHeader .= $_;
                    }
                }
            }
            elsif(/^MESSAGE_FOOTER_BEGIN/)
            {
                $HTMLMessageFooter = "";
                message_footer_loop: while(<CONFIG>)
                {
                    if(/^MESSAGE_FOOTER_END/){ last message_footer_loop; }
                    else
                    {
                        $HTMLMessageFooter .= $_;
                    }
                }
            }
            elsif(/^SEND_MESSAGE_HEADER_BEGIN/)
            {
                $HTMLSendMessageHeader = "";
                send_message_header_loop: while(<CONFIG>)
                {
                    if(/^SEND_MESSAGE_HEADER_END/){ last send_message_header_loop; }
                    else
                    {
                        $HTMLSendMessageHeader .= $_;
                    }
                }
            }
            elsif(/^SEND_MESSAGE_FOOTER_BEGIN/)
            {
                $HTMLSendMessageFooter = "";
                send_message_footer_loop: while(<CONFIG>)
                {
                    if(/^SEND_MESSAGE_FOOTER_END/){ last send_message_footer_loop; }
                    else
                    {
                        $HTMLSendMessageFooter .= $_;
                    }
                }
            }
            elsif(/^FORWARD_HEADER_BEGIN/)
            {
                $HTMLForwardHeader = "";
                forward_header_loop: while(<CONFIG>)
                {
                    if(/^FORWARD_HEADER_END/){ last forward_header_loop; }
                    else
                    {
                        $HTMLForwardHeader .= $_;
                    }
                }
            }
            elsif(/^SEND_ACK_BEGIN/)
            {
                $HTMLSendAck = "";
                send_ack_loop: while(<CONFIG>)
                {
                    if(/^SEND_ACK_END/){ last send_ack_loop; }
                    else
                    {
                        $HTMLSendAck .= $_;
                    }
                }
            }
        }
        close(CONFIG);
    }

    # Fill in defaults for any HTML templates that are not present
    $HTMLHeader = <<'EndOfHeader' unless $HTMLHeader;
<html>
<body bgcolor="#ffffff">
<basefont face="Arial">
<META HTTP-EQUIV="pragma" CONTENT="no-cache">
<title><PAGE_TITLE></title>
<body>
EndOfHeader

    $HTMLFooter = <<'EndOfFooter' unless $HTMLFooter;
</body>
</html>
EndOfFooter

    $HTMLLogin = <<'EndOfLogin' unless $HTMLLogin;
<center><h1>MailMan</h1></center>
Welcome to MailMan!  For more information about what this
program is, and what it does, see the 
<a href="http://www.endymion.com/portfolio/software/scripts/mailman.htm">MailMan page</a> at 
<a href="http://www.endymion.com/">Endymion Corporation</a>.  To check your
mail now, login here:<br>
<form method="post" action="<MAILMAN>">
<b>Login:</b> <input type="text" name="LOGIN" size="30" value="<LOGIN>"><br>
<b>Password:</b> <input type="password" name="PASSWORD" size="30" value="<PASSWORD>"><br>
<b>Server:</b> <input type="text" name="SERVER" size="30" value="<SERVER>"><br>
<input type="submit" name="MAILMAN_LOGIN" value="Login"><br>
</form>
</center>
EndOfLogin

    $HTMLMessagesHeader = <<'EndOfMessagesHeader' unless $HTMLMessagesHeader;
<b><LOGIN>@<SERVER></b><br>

<form method="post" action="<MAILMAN>">
<input type="hidden" name="LOGIN" value="<HIDDEN_LOGIN>">
<input type="hidden" name="PASSWORD" value="<HIDDEN_PASSWORD>">
<input type="hidden" name="SERVER" value="<HIDDEN_SERVER>">

<input type="submit" name="MAILMAN_LOGIN" value="Reload Contents"> | <input type="submit" name="MAILMAN_NEW" value="New"><br>
<br>
<h2>This account has <MESSAGE_NUMBER> messages:</h2>
EndOfMessagesHeader

    $HTMLMessagesFooter = <<'EndOfMessagesFooter' unless $HTMLMessagesFooter;
</form>
EndOfMessagesFooter

    $HTMLMessageInfo = <<'EndOfMessageInfo' unless $HTMLMessageInfo;
<b>Subject:</b> <SUBJECT><br>
<input type="submit" name="SHOW:<ID>" value="Show">
<input type="submit" name="DELETE:<ID>" value="Delete">
<b>From:</b> <FROM><br>
<b>Date:</b> <DATE><br>
<b>Size:</b> <SIZE><br>
-----------------------<br>
<br>
EndOfMessageInfo

    $HTMLMessageHeader = <<'EndOfMessageHeader' unless $HTMLMessageHeader;
<form method="post" action="<MAILMAN>">
<input type="hidden" name="LOGIN" value="<HIDDEN_LOGIN>">
<input type="hidden" name="PASSWORD" value="<HIDDEN_PASSWORD>">
<input type="hidden" name="SERVER" value="<HIDDEN_SERVER>">

<input type="submit" name="MAILMAN_LOGIN" value="Contents"> | <input type="submit" name="MAILMAN_NEW" value="New"><br>
<PREVBUTTON>
<NEXTBUTTON>
<br>
<input type="submit" name="DELETE:<ID>" value="Delete"> | <input type="submit" name="REPLY:<ID>" value="Reply"> | <input type="submit" name="REPLYALL:<ID>" value="Reply All"> | <input type="submit" name="FORWARD:<ID>" value="Forward"><br>
<br>
<b>Subject:</b> <SUBJECT><br>
<b>From:</b> <FROM><br>
<b>To:</b> <TO><br>
<CC><br>
<b>Date:</b> <DATE><br>

EndOfMessageHeader

    $HTMLMessageFooter = <<'EndOfMessageFooter' unless $HTMLMessageFooter;
EndOfMessageFooter

    $HTMLSendMessageHeader = <<'EndOfSendMessageHeader' unless $HTMLSendMessageHeader;
<form method="post" action="<MAILMAN>">
<input type="hidden" name="MAILMAN" value="SEND">
<input type="hidden" name="LOGIN" value="<HIDDEN_LOGIN>">
<input type="hidden" name="PASSWORD" value="<HIDDEN_PASSWORD>">
<input type="hidden" name="SERVER" value="<HIDDEN_SERVER>">

<b>To:</b> <input type="text" name="TO" size="40" value="<TO>"><br>
<b>CC:</b> <input type="text" name="CC" size="40" value="<CC>"><br>
<b>From:</b> <input type="text" name="FROM" size="40" value="<FROM>"><br>
<b>Subject:</b> <input type="text" name="SUBJECT" size="40" value="<SUBJECT>"><br>
<b>SMTP Server:</b> <input type="text" name="OUTGOING" size="40" value="<OUTGOING>"><br>
<br>
<textarea name="TEXT" rows=40 cols=80>
EndOfSendMessageHeader

    $HTMLSendMessageFooter = <<'EndOfSendMessageFooter' unless $HTMLSendMessageFooter;
</textarea>
<br>
<input type="submit" name="MAILMAN_SEND" value="Send"> | <input type="submit" name="SHOW:<ID>" value="Cancel">
</form>
EndOfSendMessageFooter

    $HTMLForwardHeader = <<'EndOfForwardHeader' unless $HTMLForwardHeader;

Forwarded Message Follows:
From: <FROM>
To: <ORIGINAL_TO>
Date: <DATE>
Subject: <ORIGINAL_SUBJECT>
-----
EndOfForwardHeader

    $HTMLSendAck = <<'EndOfSendAck' unless $HTMLSendAck;
<center>
<h1>Your message has been sent.</h1>
<form method="post" action="<MAILMAN>">
<input type="hidden" name="LOGIN" value="<HIDDEN_LOGIN>">
<input type="hidden" name="PASSWORD" value="<HIDDEN_PASSWORD>">
<input type="hidden" name="SERVER" value="<HIDDEN_SERVER>">
<input type="submit" name="MAILMAN_LOGIN" value="Return To Contents">
</form>
<font size=1><i>Note: Don't reload this page.  If you do, your
message may be sent again, depending upon your browser's form
reloading behavior.</i></font>
</center>
EndOfSendAck
}

# This routine is used to interpolate variables into the HTML
# templates specified in a configuration file.
sub InterpolateVariables
{
    my($string,@variables) = @_;
    my($name,$interpolant);

    # Process each pair in the input list.
    while($name=shift(@variables))
    {
        $interpolant = shift(@variables);

        # Do the substitution.
        $string =~ s/$name/$interpolant/g;
    }

    # This should *always* be interpolated.
    $string =~ s/<MAILMAN>/$Me/g;

    return $string;
}

# Takes <cleartext>, returns <ciphertext>.
sub HideString
{
    my($cleartext) =  @_;

    $key = ConnectionKey(length($cleartext));
    $ciphertext = $cleartext ^ $key;
    $ciphertext = pack("u*",$ciphertext);
    chop($ciphertext);
    $ciphertext =~ s/(\W)/sprintf("%%%x", ord($1))/eg;

    return "%%%%$ciphertext%%%%";
}

# Takes <cipertext>, returns <cleartext>.
sub UnhideString
{
    my($ciphertext) =  @_;

    if($ciphertext =~ /\%\%\%\%(.+)\%\%\%\%/)
    {
	$ciphertext = $1;
    }
    else
    {
	return $ciphertext;
    }

    $ciphertext =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
    $ciphertext = unpack("u*",$ciphertext);
    $key = ConnectionKey(length($ciphertext));
    $cleartext = $ciphertext ^ $key;

    return $cleartext;
}

# Do anything that is OS-specific.  This is an attempt to make
# porting easier for people that don't actually read my code.
sub OSSettings
{
    # Detect the OS.
    eval '$os = `uname`';
	$os = 'Unix' if $os;  # if you just need generic OS
	$os = 'Mac' if defined( $MacPerl'Version );
    $os = 'NT' if ($] =~ /NT/) && ! $os;
   	$os = 'Dos' unless $os;

    if($os eq 'Unix')
    {
        $UseAlarm = TRUE;
    }
    elsif($os eq 'Mac')
    {
        # Is this right?  Does MacPerl do alarms?
        $UseAlarm = FALSE;
    }
    elsif($os eq 'NT')
    {
        $UseAlarm = FALSE;
    }
    elsif($os eq 'Dos')
    {
        $UseAlarm = FALSE;
    }
}

# This routine is originally from cgi-lib.pl, by S.E.Brenner@bioc.cam.ac.uk
# Copyright notice from cgi-lib.pl:
############################################################
# Copyright 1994 Steven E. Brenner  
# Unpublished work.
# Permission granted to use and modify this library so long as the
# copyright above is maintained, modifications are documented, and
# credit is given for any use of the library.
#
# Thanks are due to many people for reporting bugs and suggestions
# especially Meng Weng Wong, Maki Watanabe, Bo Frese Rasmussen,
# Andrew Dalke, Mark-Jason Dominus and Dave Dittrich.
#
# For more information, see:
#     http://www.bio.cam.ac.uk/web/form.html       
#     http://www.seas.upenn.edu/~mengwong/forms/   
############################################################
sub ReadParse
{
  local (*in) = @_ if @_;
  local ($i, $key, $val);

  # Read in text
  read(STDIN,$in,$ENV{'CONTENT_LENGTH'});

  @in = split(/&/,$in);

  foreach $i (0 .. $#in) {
    # Convert plus's to spaces
    $in[$i] =~ s/\+/ /g;

    # Split into key and value.  
    ($key, $val) = split(/=/,$in[$i],2); # splits on the first =.

    # Convert %XX from hex numbers to alphanumeric
    $key =~ s/%(..)/pack("c",hex($1))/ge;
    $val =~ s/%(..)/pack("c",hex($1))/ge;

    # Check for special conditions (MailMan only!)
    if($key =~ /SHOW:(\S+)$/)
    {
        $in{'MAILMAN_DISPLAY'} = 'Show';
        $in{'ID'} = $1;
    }
    if($key =~ /DELETE:(\S+)$/)
    {
        $in{'MAILMAN_DELETE'} = 'Delete';
        $in{'ID'} = $1;
    }
    if($key =~ /REPLY:(\S+)$/)
    {
        $in{'MAILMAN_REPLY'} = 'Reply';
        $in{'ID'} = $1;
    }
    if($key =~ /REPLYALL:(\S+)$/)
    {
        $in{'MAILMAN_REPLYALL'} = 'Reply All';
        $in{'ID'} = $1;
    }
    if($key =~ /FORWARD:(\S+)$/)
    {
        $in{'MAILMAN_FORWARD'} = 'Forward';
        $in{'ID'} = $1;
    }
    
    # Associate key and value
    $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator
    $in{$key} .= $val;

  }

  return length($in); 
}


sub unescapeURL
{
    # Note from RFC1630:  "Sequences which start with a percent sign
    # but are not followed by two hexadecimal characters are reserved
    # for future extension"
    my $str = shift;
    if (@_ && wantarray) {
	# not executed for the common case of a single argument
	my @str = @_;  # need to copy
	return map { s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg } $str, @str;
    }
    $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    $str;
}