#!/usr/bin/perl -w
$| = 1;

# Decimail Webmail
# http://decimail.org/webmail/
# (formerly just called "Phil's Webmail")

# Scroll down about 70 lines for things to configure.

# Based originally on webmail version 2.3.14 by Jason Woodward
# Comprehensively modified by Phil Endecott
# (C) the respective authors

# This is version $Name$
#   (if there is no version (e.g. V2-2) mentioned in the previous line,
#    this is probably a snapshot from between "official" releases.)

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.



# TODO:

# Ought to check for and report any errors while deleting messages.

# The from: address menu doesn't set the corresponding text entry when
# used with Internet Explorer (javascript problem?).
# [This should be fixed now, but I await confirmation from an IE user.]


use lib '.';

use CGI qw(:standard escapeHTML unescapeHTML);
use CGI::Carp qw(fatalsToBrowser);
use Mail::POP3Client;
use MIME::Lite;
use Net::SMTP;
use MIME::Parser;
use URI::Escape;
use URI::Find;
use Text::Wrap;
use Date::Parse;
use POSIX qw(strftime);
use MIME::Words qw(decode_mimewords);

use strict;


$Text::Wrap::columns = 80;


# Set the following variables to suit your local setup
# ----------------------------------------------------

# (Or set them in an external file; see below.)

# Note that Perl syntax requires a \ before @ in the all the following
# variables.

# How to connect to the POP server
my $popserver="MY-POP-SERVER";
my $username="MY-USERNAME";
my $password="MY-PASSWORD";

# Authorisation mode can be PASS (plaintext password), APOP (encrypted
# password), or BEST (use APOP if available, else PASS).
my $popauthmode="BEST";

# Full name of user (appears in From: headers and also in the title of
# the web pages).
my $fullname="Fred Bloggs";

# Identity information used to initialise the From: field in outgoing
# messages.
# The From: field has a menu listing possible addresses.  The following
# addresses are always included.
my @emailaddresses=("ME\@MY-DOMAIN","OTHER\@ELSEWHERE");

# Anti-spam From: addresses
# -------------------------

# (You can skip this section at first if you aren't sure about it.)

# You can choose to have a random address in the menu of from
# addresses (useful as an anti-spam measure if you have your own
# domain.)  See the random_addr function for details.  This is the
# template used to generate the addresses.  RAND is replaced with a
# random string.
my $rand_addr_template="RAND\@MY-DOMAIN";

# You can also choose to have a non-random anti-spam From: address in
# replies; when you get a message from someone@xyz.com, you can have
# your reply come from an address like "spam_from_xyz@MY-DOMAIN".
# This line defines a template used to generate these addresses.
# DOMAIN1 is replaced with the first element of the domain of the
# original message's from: line, e.g. xyz for xyz.com.
my $spam_from_template="spam-from-DOMAIN1\@MY-DOMAIN";

# This regular expression should match all To: or Cc: addresses in an
# incoming message that may be refering to this user.  Any address matching
# this will be added to the menu of From: addresses in a reply.
my $my_addrs_re='\@MY_DOMAIN$';

# See the definition of @from_addr_list in the create_common function
# for how the From: address menu is composed.  If you want to add
# extra from address functions, or remove the ones defined here, that
# is the place to do it.

# End of anti-spam from: address stuff
# ------------------------------------

# Default address that emails are BCCed to (so that you have copies of
# everything you send).  Make it "" if you don't want to get copies.
my $bcc_address="ME\@MY-DOMAIN";

# SMTP server to use for outgoing messages
my $smtpserver="MY-SMTP-SERVER";

# Name of the machine running the CGI process, as announced to the
# SMTP server.
my $webserver="MY-DOMAIN";

# Base URI for this CGI script
my $scriptbaseuri="http://MY-DOMAIN/webmail.cgi";

# Configuration for the message list page
# Order with newest first or oldest first?
# 1 = newest first, 0 = oldest first
my $NEWESTFIRST=1;
# How many messages per page?
my $MAXMESSLISTNUM=20;

# Enable QWAZERTY keyboard mapping (http://chezphil.org/qwazerty/)
my $use_qwazerty=1;

# Enable Speller Pages spell checking (http://spellerpages.sourceforge.net)
my $use_speller=1;


# If you want, rather than changing the values of all these variables
# by editting this script, you can set then in an external perl file
# that is included at this point.  This makes it easier to upgrade to
# newer versions of the script, but might marginally slow down
# execution.  If you don't use an external file, comment out or remove
# the following line.

eval `cat ./config.pl`;

# End of configuration variables.
# -------------------------------


my $parity=0;

my $attachment1 = param("attachment1");
my $attachment2 = param("attachment2");
my $attachment3 = param("attachment3");
my $attachment4 = param("attachment4");
my $attachment5 = param("attachment5");
my @attachattachments = param("attachattachments");
my $action = param("action");
my $next_action = param("next_action");
my $uidl = param("uidl");
my $next_uidl = param("next_uidl");
my @deluidls = param("deluidls");
my @tos = param("to");
my $from = param("from");
my $subject = param("subject");
my $replyto = param("replyto");
my $in_reply_to = param("in_reply_to");
my $references = param("references");
my $mbody = param("mbody");
my $bcc = param("bcc");
my $cc = param("cc");
my $attachmentindex = param("attachmentindex");
my $lastdisplayed = param("lastdisplayed");
my $showheaders = param("showheaders");
my $listall = param("listall");

my $to = join(", ",@tos);

my $header_printed=0;
my $page_can_be_cached;

if(!defined($action)) {
  #$action="listmessages";
  $action="showframes";
}

my $pop;

if ($action eq "getattachment") {
  $pop = open_pop3_connection($username,$password,1);
  &getattachment(\$pop,$uidl,$attachmentindex);
  exit 0;
} else {
  if ($action eq "sendmessage") {
    sendmessage($to,$from,$mbody,$replyto,$subject,$cc,$bcc,
		$in_reply_to,$references,
		$attachment1,$attachment2,$attachment3,$attachment4,
		$attachment5,@attachattachments);
    $action="closewindow";
  }
  if ($action eq "showframes") {
    &showframes();
    exit 0;
  }
  if ($action eq "closewindow") {
    &closewindow();
    exit 0;
  }
  if ($action eq "deletemessage") {
    $pop = open_pop3_connection($username,$password,1);
    if($deluidls[0]){
      foreach(@deluidls){
	&deletemessage(\$pop,$_);
      }
    }else{
      &deletemessage(\$pop,$uidl);
    }
    $pop->Close();
    $action=$next_action;
    $uidl=$next_uidl;
  }
  if ($action eq "blank") {
    &print_header(0);
    &print_footer();
    exit 0;
  }
  $pop = open_pop3_connection($username,$password,0);
  if ($action eq "listmessages") {
    &listmessages(\$pop,$lastdisplayed,$listall);
  } elsif ($action eq "readmessage") {
    &readmessage(\$pop,$uidl,$showheaders);
  } elsif ($action eq "createmessage") {
    &createmessage($to);
  } elsif ($action eq "replymessage") {
    &replymessage(\$pop,$uidl);
  } elsif ($action eq "replyallmessage") {
    &replyallmessage(\$pop,$uidl);
  } elsif ($action eq "forwardmessage") {
    &forwardmessage(\$pop,$uidl);
  } else {
    &errorpage("ERROR!! NOTHING TO DO");
  }
  &print_footer();
}

### close any open connections
if($pop){$pop->Close();}
### clear all params (mod_perl)
Delete_all();
### goodbye
1;


# If an error occurs, this MAY get called, if we're lucky, to close
# any POP connection.  That may save us from having to wait for the
# POP server to time out before we can try again.
END {
  if ($pop) {
    $pop->Close();
  }
}


### Open a connection to the POP3 server
sub open_pop3_connection {
  my($username,$password,$retry_if_locked) = @_;

  my $tries = 0;

  while (1) {

    my $pop = new Mail::POP3Client(USER => $username,
				   PASSWORD => $password,
				   HOST => $popserver,
				   AUTH_MODE => $popauthmode
				  );
    my $servermessage = $pop->Message;
    if ($servermessage =~ /^\+OK/) {
      return $pop;
    }
    my $errormsg;
    if ($servermessage =~ m/ERR(.*)/) {
      $errormsg = $1;
    } else {
      $errormsg = "no error message available";
    }
    if ($errormsg =~ m/lock/i) {
      if ($retry_if_locked) {
	$tries++;
	if ($tries<150) {
	  sleep 2;
	  next;
	} else {
	  $errormsg .= " after $tries attempts";
	}
      }
    }
    &errorpage("POP3 connection failed: $errormsg");

  }
}


sub errorpage {
  my ($msg) = @_;
  &print_header(0);
  print qq!<p class="error">$msg</p>!;
  &print_footer();
  if($pop){$pop->Close();}
  exit;
}


sub createmessage {
  # Starting point when action=createmessage
  my ($to) = @_;

  &create_common($to,"","","","","");
}


sub create_common {
  # Shared code used to create a message composition window used for
  # create, reply, reply-all and forward.
  # Takes initial values for the To: and Subject: header fields, the
  # message body, and codes representing a message's attachments to be
  # presented for possible sending.
  my ($to,$orig_to,$subject,$in_reply_to,$references,$mbody,
      @attachment_codes) = @_;

  $to = escapeHTML($to);
  $subject = escapeHTML($subject);
  $in_reply_to = escapeHTML($in_reply_to);
  $references = escapeHTML($references);
  $mbody = escapeHTML($mbody);

  &print_header(1,"compose");

  print qq!
<form action="$scriptbaseuri" method="POST" enctype="multipart/form-data" name="theform">
!;

  my $qw_attr = "";
  if ($use_qwazerty) {
    &print_qw_init();
    $qw_attr = qq!onkeypress="qw_changeKey(this,event,qw_qwazertyconv);"!;
  }

  my $spell_button = "";
  if ($use_speller) {
    &print_speller_init();
  }

  my ($from_addr,@from_addrs);

  # Create the list of possible From: addresses from which the user
  # can select one.  This includes the fixed list of addresses in
  # @emailaddresses and the results of a couple of functions.  Change
  # this to suit your needs.

  my @from_addr_list=($orig_to,@emailaddresses,&random_addr(),&spam_from($to));

  my $a;
  foreach $a (@from_addr_list) {
    if ($a) {
      push @from_addrs,qq|"$fullname" <$a>|;
    }
  }
  my $escaped_from_addr_0=escapeHTML($from_addrs[0]);

  print qq|
<script language="javascript" type="text/javascript"><!--
function clearbody() { document.getElementById("mbody").value=""; }
function setfrom(v) { document.getElementById("from").value=v; }
// -->
</script>
<div class="toolbar">
<input type="hidden" name="action" value="sendmessage">
<input type="hidden" name="in_reply_to" value="$in_reply_to">
<input type="hidden" name="references" value="$references">
<input type="submit" value="Send">
|;
  &print_js_button("Clear body","clearbody();");
  if ($use_speller) {
    &print_js_button("Check Spelling","openSpellChecker();");
  }
  print qq|</div>
<table>
<tr>
  <td class="headername">From:</td>
  <td>
    <select name="choosefrom" onChange="setfrom(this.options[this.selectedIndex].value);">
      |;
  foreach $from_addr (@from_addrs) {
    my $escaped_from_addr = escapeHTML($from_addr);
    print qq|<option value="$escaped_from_addr">$escaped_from_addr</option>|;
  }
  print qq|
    </select><br/>
    <input type="text" name="from" id="from" size="50" value="$escaped_from_addr_0">
  </td>
</tr>
<tr>
  <td class="headername">To:</td>
  <td><input type="text" name="to" size="50" value="$to" $qw_attr></td>
</tr>
<tr>
   <td class="headername">Cc:</td>
   <td><input type="text" name="cc" size="50" $qw_attr></td>
</tr>
<tr>
   <td class="headername">Bcc:</td>
   <td><input type="text" name="bcc" size="50" value='"$fullname" &lt;$bcc_address&gt;' $qw_attr></td>
</tr>
<tr>
   <td class="headername">ReplyTo:</td>
   <td><input type="text" name="replyto" size="50" $qw_attr></td>
</tr>
<tr>
   <td class="headername">Subject:</td>
   <td><input type="text" id="subject" name="subject" size="50" value="$subject" $qw_attr></td>
</tr>
</table>
<div><textarea rows="25" cols="80" id="mbody" name="mbody" $qw_attr>
$mbody
</textarea></div>|;

  if ($use_qwazerty) {
    &print_qw_menus();
  }
  print qq|
<table>
<tr>
   <td class="headername">Attachment 1:</td>
   <td><input type="file" name="attachment1" size="40"></td>
</tr>
<tr>
   <td class="headername">Attachment 2:</td>
   <td><input type="file" name="attachment2" size="40"></td>
</tr>
<tr>
   <td class="headername">Attachment 3:</td>
   <td><input type="file" name="attachment3" size="40"></td>
</tr>
<tr>
   <td class="headername">Attachment 4:</td>
   <td><input type="file" name="attachment4" size="40"></td>
</tr>
<tr>
   <td class="headername">Attachment 5:</td>
   <td><input type="file" name="attachment5" size="40"></td>
</tr>
  |;

  # There is some code at http://www.quirksmode.org/dom/usableforms.html
  # that shows how to dynamically change the number of attachment entry
  # fields

  my $attachment_code;
  foreach $attachment_code (@attachment_codes) {
    my $html_escaped_attachment_code = escapeHTML($attachment_code);
    my ($uidl,$fn,$type,$attachmentindex) =
      &decode_attachment_code($attachment_code);
    my @partnumbers = split(/,/,$attachmentindex);

    print qq!
<tr>
  <td class="headername">Forwarded attachment:</td>
  <td>
    !;
    print &html_for_attachment($uidl,$fn,$type,@partnumbers);
    print qq!
  </td>
  <td><input type="checkbox" name="attachattachments" value="$html_escaped_attachment_code" checked="checked"></td>
</tr>
      !;
  }

  print qq!
</table></form>!;
}


sub listmessages {
  # Starting point when action=listmessages.
  my ($pop_ref,$lastdisplayed,$listall) = @_;

  my ($firstmessage,$lastmessage,@message_index);

  my @messagesizes = $$pop_ref->ListArray();
  my $message_count = $$pop_ref->Count();

  my $messlistnum;
  if ($listall) {
    $messlistnum=2000;
  } else {
    $messlistnum=$MAXMESSLISTNUM;
  }

  if ($NEWESTFIRST) {
    if($lastdisplayed){
      $firstmessage = ($lastdisplayed - 1);
      $lastmessage = 1;
      if(($lastdisplayed - $messlistnum) > 0){
	$lastmessage = ($lastdisplayed - $messlistnum);
      }
    }else{
      $firstmessage = $message_count;
      $lastmessage = 1;
      if($firstmessage > $messlistnum){
	$lastmessage = ($firstmessage - $messlistnum) + 1;
      }
    }
  }else {
    if($lastdisplayed){
      $firstmessage = ($lastdisplayed + 1);
      $lastmessage = $message_count;
      if(($lastmessage - $lastdisplayed) > $messlistnum){
	$lastmessage = ($lastdisplayed + $messlistnum);
      }
    }else{
      $firstmessage = 1;
      $lastmessage = $message_count;
      if($lastmessage > $messlistnum){
	$lastmessage = $messlistnum;
      }
    }
  }

  @message_index = $NEWESTFIRST ? reverse ( $lastmessage .. $firstmessage )
    : ( $firstmessage .. $lastmessage );

  &print_header(0);

  print qq@
    <script language="javascript" type="text/javascript">
<!--
@;
&print_shared_js();
  print qq@
  var currentrow;
  var currentrow_prevclass;
  // The following findPosY function is from
  //   http://www.quirksmode.org/js/findpos.html
  // which allows one to "copy, tweak, rewrite, sell or lease" it.
  function findPosY(obj)
  // find the Y position of an element on the page
  {
    var curtop = 0;
    if (obj.offsetParent) {
      while (obj.offsetParent) {
        curtop += obj.offsetTop
        obj = obj.offsetParent;
      }
    } else if (obj.y) {
      curtop += obj.y;
    }
    return curtop;
  }

  function set_current(idsubstr) {
    if (currentrow && currentrow.className=="current") {
      currentrow.className = currentrow_prevclass;
    }
    currentrow = document.getElementById(idsubstr);
    currentrow_prevclass = currentrow.className;
    currentrow.className = "current";
    var y = findPosY(currentrow);
    if ((y<window.scrollY) || (y>(window.scrollY+window.innerHeight))) {
      window.scrollTo(0,y-window.innerHeight/3);
    }
  }
  function set_deleted(idsubstr) {
    var row = document.getElementById(idsubstr);
    row.className = "deleted";
  }
//-->
    </script>
    <form action="$scriptbaseuri" method="POST">
      @;

  my %lom = (); # list of messages
  my $i;
  foreach $i (@message_index) {
    my ($from,$subject,$date,$datenum,$sizeofmess);
    my $header;
    foreach $header ($$pop_ref->Head($i)) {
      if ($header =~ /^From:\s+(.*)/i) {
	$from = decode_mimewords($1);
      }
      if ($header =~ /^Subject:\s+(.*)/i) {
	$subject = decode_mimewords($1);
      }
      if ($header =~ /^Date:\s+(.*)/i) {
	$date = decode_mimewords($1);
	$datenum = str2time($date);
      }
    }
    $sizeofmess = sprintf("%.1fk",$messagesizes[$i]/1000);
    if (!defined($subject) || $subject eq "") {
      $subject = "No Subject";
    }
    if(!defined($from) || $from eq ''){
      $from = "No From Address";
    }
    $from =~ s/\"//g;
    my $uidl = &lookup_uidl($pop_ref,$i);
    $lom{$i} = [ $from, $subject, $date, $datenum, $sizeofmess, $uidl ];
  }

  print qq|<div class="toolbar">|;
  &print_button(1,"emailbook.html","Address Book");
  &print_action_button(1,"Compose Message","createmessage");
  &print_action_button(0,"Get New","listmessages");

  print qq|Displaying $firstmessage - $lastmessage of $message_count|;

  if( ($NEWESTFIRST && ($lastmessage <= 1))
      || (!$NEWESTFIRST && ($lastmessage >= $message_count ) ) ) {
  } else {
    # page up?
    &print_action_button(0,"Page Down","listmessages;lastdisplayed=$lastmessage");
    &print_action_button(0,"All","listmessages;listall=y");
  }
  print qq|</div>
|;

  print qq|
<table class="messagelist">
<col class="from"/><col class="subject"/><col class="date"/><col class="size"/><col class="delete"/>
<tr class="header"><td>From</td><td>Subject</td><td>Date</td><td>Size</td>
<td><input type="hidden" name="action" value="deletemessage">
<input type="hidden" name="next_action" value="listmessages">
<input type="submit" value="Delete"></td></tr>
|;

  $parity=0;
  for $i (@message_index) {
    &list_message(${$lom{$i}}[0],${$lom{$i}}[1],${$lom{$i}}[2],
                  ${$lom{$i}}[4],${$lom{$i}}[5]);
  }

  print qq|</table></form><script language="javascript" type="text/javascript">
<!--
  if (window.top.message.msglist_reloaded) {
    window.top.message.msglist_reloaded();
  }
// -->
</script>|;
}


sub list_message {
  my ($from,$subject,$dateofmess,$sizeofmess,$uidl) = @_;

  $from =~ s/\(.*\)//g;
  if($from eq '' || !$from){
    $from = "No From Address";
  }
  $from=escapeHTML($from);
  $subject=escapeHTML($subject);
  $dateofmess=escapeHTML($dateofmess);
  my $uri_escaped_uidl=&my_uri_escape($uidl);
  my $html_escaped_uidl=escapeHTML($uidl);
  my $idsubstr=&get_idsubstr($uidl);

  my $readlink = qq|<a target="message" href="$scriptbaseuri?action=readmessage;uidl=$uri_escaped_uidl">|;

  print qq!
    <tr class="r$parity" id="$idsubstr">
    <td>$readlink$from</a></td>
    <td>$readlink$subject</a></td>
    <td>$readlink$dateofmess</a></td>
    <td class="size">$readlink$sizeofmess</a></td>
    <td class="delete"><input type="checkbox" name="deluidls" value="$html_escaped_uidl"></td>
    </tr>
      !;
  $parity=1-$parity;
}


sub get_idsubstr {
  # Given a message UID, strip all the nasty characters.
  # The result is less unique, but is only used in places where that
  # doesn't really matter.
  my ($uid) = @_;
  my $idsubstr = $uid;
  $idsubstr =~ tr/a-zA-Z0-9//cd;
  return $idsubstr;
}


sub split_addr_list {
  # Given an address list eg
  # foo@blah.com, "Mr Foo" <foo@blah.com>, "Foo, Bill" <foo@blah.com>
  # return each address as a list.
  # Note the hard case where there is a , in the fullname.

  my ($list)=@_;

  my @addrs = split(/,\s*(?![^"]*"\s*<)/, $list);

  return @addrs;
}


sub sendmessage {
  # Starting point when action=sendmessage
  my ($to,$from,$mbody,$replyto,$subject,$cc,$bcc,
      $in_reply_to,$references,
      $attachment1,$attachment2,$attachment3,$attachment4,$attachment5,
      @attachattachments) = @_;

  chomp($to,$from,$mbody,$replyto,$subject,$cc,$bcc,$in_reply_to,$references,
	$attachment1,$attachment2,$attachment3,$attachment4,$attachment5);

  my $date = strftime("%a, %d %b %Y %H:%M:%S %z", localtime());

  my @to = &split_addr_list($to) if defined($to);
  my @cc = &split_addr_list($cc) if defined($cc);
  my @bcc = &split_addr_list($bcc) if defined($bcc);

  my @recipients = (@to,@cc,@bcc);
  if (!@recipients) {
    &errorpage("Warning: No recipients specified");
    return;
  }

  # Need to escape any . on a line of its own, since this is special
  # to SMTP.  Append a space.  But maybe Net::SMTP does this for us?
  $mbody =~ s/\n\.(\r|\n)/\n. $1/g;

  my $smtp=Net::SMTP->new("$smtpserver",
			  Hello => "$webserver");

  if (!$smtp) {
    &errorpage("Error: Failed to create SMTP connection");
  }

  if (!$smtp->mail($from)) {
    &errorpage("Error: SMTP MAIL FROM failed");
  }
  # Not clear if Net::SMTP extracts the email addresses from longer
  # strings containing full names, or whether we ought to be doing
  # that here.
  if (!$smtp->recipient(@recipients)) {
    &errorpage("Error: SMTP RCPT TO failed");
  }

  my $rand = int(rand(10000000));
  my $msg_id = "<$rand\@$webserver>";

  my $msg = MIME::Lite->new(From => $from,
			    To => join(', ', @to),
			    Cc => join(', ', @cc),
			    'Reply-To' => $replyto,
			    Subject => $subject,
			    Date => $date,
			    'X-Mailer' => "Decimail WebMail",
			    'Message-ID' => $msg_id,
			    Type => "TEXT",
			    Data => $mbody
			   );

  if ($in_reply_to) {
    $msg->add("In-Reply-To" => $in_reply_to);
  }

  if ($references) {
    $msg->add("References" => $references);
  }

  my $attachment;
  my $n=1;

  foreach $attachment ($attachment1,$attachment2,$attachment3,$attachment4,
		       $attachment5) {
    if ($attachment) {
      my $fh = upload("attachment$n");
      # Hmm, not sure about that line - "man CGI" doesn't document it;
      # I think we should be using $attachment as the filehandle.
      # Maybe this is a CGI.pm version thing.

      my $attachment_type;
      # Try and work out a Content-Type for the uploaded file.

      # It would be good to get the type from the browser, but the
      # following doesn't seem to work, not sure why:
      # $uploadInfo($attachment)->{'Content-Type'};

      # Instead, run "file" on the uploaded file.
      # I have a script called magic2mime that takes the output from
      # "file" and returns a mime type, but my ISP doesn't have it so
      # instead I'll do it by hand here.
      # It would be good if we could get the filename for the temporary
      # file that CGI.pm has created, but this isn't in the public
      # interface and hacking at the innards to get it didn't work.
      # Instead we have to copy the contents of the file - yuk.

      # In principal we could probably get away with just copying the
      # first chunk of the file since we know that "file" only looks for
      # magic numbers, but let's not risk it.  Bear in mind that the
      # time taken here is added on to a significant upload time, so the
      # user is not going to care much about a few more miliseconds.

      my $tmpfn = "/tmp/pwebmail-file-$$";
      open (TMPFILE,">$tmpfn");
      my $buffer;
      my $bytesread;
      while ($bytesread=read($fh,$buffer,1024)) {
	print TMPFILE $buffer;
      }
      close TMPFILE;
      seek($fh,0,0);
      open(FILE_OUTPUT,"file -b $tmpfn|");
      my $magic_type = <FILE_OUTPUT>;
      close FILE_OUTPUT;
      unlink $tmpfn;

      $attachment_type = &magic2mime($magic_type);

      my ($basename) = ($attachment =~ m/([^\\\/:]*$)/);

      $msg->attach(Type => $attachment_type,
		   Filename => $basename,
		   FH => $fh
		  );
    }
    $n++;
  }

  if (@attachattachments) {
    my $pop = open_pop3_connection($username,$password,0);
    my $attachment_code;
    foreach $attachment_code (@attachattachments) {
      my ($uidl,$fn,$type,$attachmentindex) =
	&decode_attachment_code($attachment_code);
      my $data = get_attachment_data(\$pop,$uidl,$attachmentindex);
      $msg->attach(Type => $type,
		   Filename => $fn,
		   Data => $data
		  );
    }
    $pop->Close();
  }
    
  if (!$smtp->data($msg->as_string())) {
    &errorpage("Error: SMTP DATA failed");
  }
  if (!$smtp->dataend()) {
    &errorpage("Error: SMTP failed at end of data");
  }
  $smtp->quit();
}
	

sub magic2mime {
  # This function copied from the magic2mime program.
  # Which claims to beCopyright (c) 1996, 1997 vax@linkdead.paranoia.com
  # Comes with Debian so must be free - but ought to check!!!
  my ($magic_type) = @_;

  # This mapping is scanned from end backto start, so more specific
  # patterns should be later.  HOWEVER the author seems to have got
  # this a bit wrong in some cases, see audio/mpeg and video/mpeg.

  my @mapping =
    (
     # defaults
     'data' => 'application/octet-stream',
     'text' => 'text/plain',
     # more specific
     '^Rich Text Format data' => 'text/richtext',
     '^HTML document text' => 'text/html',
     '^exported SGML document text' => 'text/sgml',
     'mail text' => 'message/rfc822',
     'news text' => 'message/news',
     '^PostScript document text.*type EPS' => 'image/eps',
     '^PostScript document text' => 'application/postscript',
     '^PDF document' => 'application/pdf',
     '^Rich Text Format' => 'application/rtf',
     '^TeX DVI file' => 'application/x-dvi',
     '^BinHex binary text' => 'application/mac-binhex40',
     '^Zip archive data' => 'application/zip',
     'Microsoft Word[ 0-9.]*document data' => 'application/msword',
     '^PGP key' => 'application/pgp-keys',
     '^PGP encrypted' => 'application/pgp-encrypted',
     '^PGP armored data signature' => 'application/pgp-signature',
     '^JPEG image' => 'image/jpeg',
     '^GIF image' => 'image/gif',
     '^PNG image' => 'image/png',
     '^TIFF image' => 'image/tiff',
     'Computer Graphics Metafile' => 'image/cgf',
     '^Sun/NeXT audio data' => 'audio/basic',
     '^MPEG.*layer 3 audio' => 'audio/mpeg',
     '^MPEG' => 'video/mpeg',
     '^Apple QuickTime movie' => 'video/quicktime',
     '^X pixmap image' => 'image/x-xpixmap',
     # made up by me
     '^bitmap' => 'image/x-bitmap',
     '^PC bitmap data, Windows 3.x format' => 'image/x-msw3bmp',
     '^FLI' => 'video/x-fli',
     '^FLC' => 'video/x-flc',
     'AVI data' => 'video/x-avi',
     'WAVE' => 'audio/x-wav',
     'VOC' => 'audio/x-voc',
     'Debian binary package' => 'application/x-debian-package',
     'compiled Java class data' => 'application/x-java',
     'MPEG.*audio stream data' => 'audio/mpeg',
     'Standard MIDI data' => 'audio/midi',
    );

  my $index = $#mapping - 1;
  while ($index > -1) {
    if ($magic_type =~ m/$mapping[$index]/) {
      return $mapping[$index + 1];
    }
    $index -= 2;
  }
  return "application/octet-stream";
}


sub deletemessage {
  my ($pop_ref,$uidl) = @_;
  my $msgnum = &lookup_msgnum($pop_ref,$uidl);
  $$pop_ref->Delete($msgnum);
}


sub print_footer {
  # Print the common footer at the end of each page
  my ($usertime,$systemtime,$child_usertime,$child_systemtime);

#  ($usertime,$systemtime,$child_usertime,$child_systemtime)=times;
#  $usertime = sprintf("%.2f",$usertime);
#  $systemtime = sprintf("%.2f",$systemtime);
#  print qq!<p class="pagefooter">User: ${usertime}s; System: ${systemtime}s</p>\n!;
  print qq!</body></html>\n!;
}


sub print_header {
  # Print the common HTTP and HTML header used by all pages.
  # Sometimes we make the page cacheable, sometimes we don't,
  # depending on the cacheable parameter.
  # print_header may get called redundantly as this simplifies some
  # other code; it checks to see if it has already been called and
  # if so does nothing.
  my ($cacheable,$pageclass) = @_;

  if ($header_printed) {
    if (!$cacheable && $page_can_be_cached) {
      print "<p>Ooops - changed our minds about cacheability</p>\n";
    }
    return;
  }

  $header_printed=1;
  $page_can_be_cached=$cacheable;

  # TO DO: not sure about this charset stuff yet
  my $charset = "ISO-8859-1";
  $charset = http("HTTP_ACCEPT_CHARSET") if http("HTTP_ACCEPT_CHARSET");

  if ($cacheable) {
    print CGI::header(-cache_control => 'public',
		      -type => 'text/html',
		      -charset => $charset
		   );
  } else {
    print CGI::header(-expires => '-1d',
		      -cache_control => 'no-cache',
		      -pragma => 'no-cache',
		      -type => 'text/html',
		      -charset => $charset
		     );
  }

  print qq|
    <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
      "http://www.w3.org/TR/html4/loose.dtd">
    <html><head><link rel="stylesheet" href="webmail.css">
    <meta http-equiv="content-script-type" content="text/javascript">
    <title>$fullname - Webmail</title></head><body class="$pageclass">
      |;
}


sub readmessage {
  # Output an HTML page for a message.
  my ($pop_ref,$uidl,$showheaders) = @_;

  &print_header(1);

  my $idsubstr = &get_idsubstr($uidl);
  print qq|
<script language="javascript" type="text/javascript">
<!--
  var msglist_frame = window.top.messagelist;
  msglist_frame.set_current("$idsubstr");
  function show_deleted () {
    msglist_frame.set_deleted("$idsubstr");
  }
  function msglist_reloaded() {
    msglist_frame.set_current("$idsubstr");
  }|;
&print_shared_js();
print qq|
//-->
</script>
|;

  my $msgnum = &lookup_msgnum($pop_ref,$uidl);
  my $prev_uidl;
  if ($msgnum > 1) {
    $prev_uidl = &lookup_uidl($pop_ref,$msgnum-1);
  } else {
    $prev_uidl = "";
  }
  my $next_uidl;
  if ($msgnum < $$pop_ref->Count()) {
    $next_uidl = &lookup_uidl($pop_ref,$msgnum+1);
  } else {
    $next_uidl = "";
  }
  &print_readmessage_buttons($uidl,$prev_uidl,$next_uidl,$showheaders);

  print &message_to_html($pop_ref,$uidl,$showheaders);
}


sub print_readmessage_buttons {
  # Print the forward/reply/next/previous etc. buttons.
  my ($uidl,$prev_uidl,$next_uidl,$showheaders) = @_;

  $uidl = &my_uri_escape($uidl);
  $next_uidl = &my_uri_escape($next_uidl);
  $prev_uidl = &my_uri_escape($prev_uidl);

  print qq|<div class="toolbar">|;
  &print_action_button(1,"Forward","forwardmessage",$uidl);
  &print_action_button(1,"Reply","replymessage",$uidl);
  &print_action_button(1,"Reply to All","replyallmessage",$uidl);

  if ($next_uidl) {
    &print_action_button(0,"Delete","deletemessage",$uidl,
			      "readmessage",$next_uidl,"show_deleted();");
  } elsif ($prev_uidl) {
    &print_action_button(0,"Delete","deletemessage",$uidl,
			      "readmessage",$prev_uidl,"show_deleted();");
  } else {
    &print_action_button(0,"Delete","deletemessage",$uidl,
			      "blank","","show_deleted();");
  }

  if ($prev_uidl) {
    &print_action_button(0,"Previous","readmessage",$prev_uidl);
  }else{
    print qq!!;
  }
  if ($next_uidl) {
    &print_action_button(0,"Next","readmessage",$next_uidl);
  }else{
    print qq!!;
  }
  if ($showheaders) {
    &print_action_button(0,"No headers","readmessage",$uidl);
  } else {
     &print_action_button(0,"Show  headers","readmessage","$uidl;showheaders=1");
  }

  print qq!</div>\n!;
}


sub message_to_html {
  # Get a specified message from the POP server and return a string of
  # HTML representing it.
  my ($pop_ref,$uidl,$showheaders) = @_;

  my $mimeentity = &get_mimeentity_from_pop($pop_ref,$uidl);

  if ($showheaders) {
    my $all_html = &get_message_as_html_with_headers($mimeentity);
    return $all_html;

  } else {
    return &whole_mimeentity_to_html($uidl,$mimeentity);
  }
}


sub whole_mimeentity_to_html {
  # Return a string of HTML representing a "whole" MIME entity,
  # i.e. the headers and the body.  mimeentity_to_html below only
  # returns the body.
  my ($uidl,$mimeentity,@partnumbers) = @_;

  my $header_html = &get_header_as_html($mimeentity);
  my $body_html = &mimeentity_to_html($uidl,$mimeentity,@partnumbers);
  return qq!<div class="message">! . $header_html . $body_html . "</div>\n";
}


sub get_mimeentity_from_pop {
  # Retrieve a message from the POP server and parse it using a MIME
  # parser.
  my ($pop_ref,$uidl) = @_;

  my $msgnum = &lookup_msgnum($pop_ref,$uidl);
  my $message = $$pop_ref->HeadAndBody($msgnum);

  my $parser = new MIME::Parser;
  $parser->output_to_core(1);
  $parser->tmp_to_core(1);
  # As an alternative to parsing "in core", MIME::Parser can save to
  # temporary files.  Due to Perl weirdness this is actually FASTER
  # than keeping it in memory!  BUT in the context of a CGI script
  # running as "nobody", using temporary files exposes your email to
  # other users.  Here are the lines to configure this if it is
  # acceptable:
  #$parser->output_under("/tmp");
  #$parser->tmp_recycling(1);

  my $mimeentity = $parser->parse_data($message) or die "parse failed\n";
  # Ought to worry about errors here and elsewhere...
  # Look in $parser->results (a MIME::Parser::Results object)

  return $mimeentity;
}


sub get_message_as_html_with_headers {
  # Return a string of HTML representing a MIME entity with "show
  # headers" enabled.  This just means returning the text of the
  # message, converted to HTML.
  my ($mimeentity) = @_;

  my $text = $mimeentity->as_string;
  return qq!<pre class="message">! . &text_to_html($text) . "</pre>\n";
}


sub get_header_as_html {
  # Return a string of HTML representing the headers - at least the
  # interesting ones - of a MIME entity.
  my ($mimeentity) = @_;

  $mimeentity->head()->decode();
  # Note this this decode assumes that the encoding is the same as
  # the HTML encoding, which means it will only work when we're decoding
  # latin1 characters.  We really ought to declare the HTML as Unicode
  # and convert everything to that.

  my $header_name;
  my $html = qq!<table class="msgheaders">!;
  foreach $header_name ("Subject","Date","From","To","Cc","Reply-to") {
    my @headers = $mimeentity->head()->get($header_name);
    if (@headers) {
      chomp @headers;
      $html .= qq!<tr><td class="headername">! . $header_name
	. qq!:</td><td class="headervalue">!
	  . &text_to_html(join(", ",@headers)) . qq!</td></tr>!;
    }
  }
  $html .= qq!</table>!;
  return $html;
}


sub mimeentity_to_html {
  # Return a string of HTML representing a MIME entity.
  my ($uidl,$mimeentity,@partnumbers) = @_;

  my $type = $mimeentity->effective_type();

  if ($type =~ m/multipart\/alternative/i) {
    return &multipart_alternative_to_html($uidl,$mimeentity,@partnumbers);
  } elsif ($mimeentity->is_multipart()) {
    return &multipart_all_to_html($uidl,$mimeentity,@partnumbers);
  } else {
    return &singlepart_to_html($uidl,$mimeentity,@partnumbers);
  }
}


sub multipart_alternative_to_html {
  # Return a string of HTML representing a multipart/alternative MIME
  # entity.
  my ($uidl,$mimeentity,@partnumbers) = @_;

  my @types;
  my $part;

  foreach $part ($mimeentity->parts()) {
    push @types,$part->effective_type();
  }
  my $best_type="";
  if (grep(/^text\/plain/i,@types)) {
    $best_type='text\/plain';
  } elsif (grep(/^text\/html/i,@types)) {
    $best_type='text\/html';
  }
  if ($best_type eq "") {
    return qq!<p class="error">No acceptably-typed entity in multipart/alternative\n! .
      "Types are: " . join(', ',@types) . "</p>\n";
  } else {
    my $n = 0;
    foreach $part ($mimeentity->parts()) {
      if ($part->effective_type() =~ /^$best_type/i) {
	return &mimeentity_to_html($uidl,$part,@partnumbers,$n);
      }
      $n++;
    }
  }
}


sub multipart_all_to_html {
  # Return a string of HTML representing a multipart - but not
  # multipart/alternaitve - MIME entity.
  my ($uidl,$mimeentity,@partnumbers) = @_;

  my $all="";
  my $part;
  my $n = 0;
  foreach $part ($mimeentity->parts()) {
    $all .= &mimeentity_to_html($uidl,$part,@partnumbers,$n);
    $n++;
  }
  return $all;
}


sub singlepart_to_html {
  # Return a string of HTML representing a non-multipart MIME entity
  # given its MIME type.
  my ($uidl,$mimeentity,@partnumbers) = @_;

  my $type = $mimeentity->effective_type();

  if ($type =~ /^text\/plain/i) {
    my $body = $mimeentity->bodyhandle();
    my $text = $body->as_string();
    return "<pre>" . &text_to_html($text) . "</pre>";
  } elsif ($type =~ /^text\/html/i) {
    my $body = $mimeentity->bodyhandle();
    my $html = $body->as_string();
    return &make_html_presentable($html);
  } elsif ($type =~ /^message\/rfc822/i) {
    return &message_rfc822_to_html($uidl,$mimeentity,@partnumbers);
  } else {
    my $head = $mimeentity->head();
    my $fn = $head->recommended_filename;
    # recommended_filename can return undef or "" if there is no filename
    # to recommend - should we worry about this?
    return &html_for_attachment($uidl,$fn,$type,@partnumbers);
  }
}


sub message_rfc822_to_html {
  # Recursively process a forwarded message.
  my ($uidl,$mimeentity,@partnumbers) = @_;

  my @parts = $mimeentity->parts();
  &whole_mimeentity_to_html($uidl,$parts[0],@partnumbers,0);
}


sub text_to_html {
  # Return a string of HTML representing message data of type text/plain.
  # Has to:
  #   Escape HTML special characters such as <
  #   Augment URIs with links
  #   Augment email addresses with links to createmessage
  #   Worry about the charset [NOT DONE YET]
  #   Wrap long lines
  my ($text) = @_;

  # The order in which things happen is difficult:
  #   We must do HTML-escaping after wrapping, since we don't want HTML
  #     entities to be broken over lines (e.g. &l\nt;).
  #   We must do HTML-escaping before grokking URIs and email addresses,
  #     since we don't want the < and >s in the inserted links to be
  #     escaped.
  #   We should do line-wrapping before grokking URIs and email addresses,
  #     since the true length, as displayed, of the line does not include
  #     the tags.
  #   We must do line-wrapping after grokking URIs and email addresses,
  #     since we don't want to split up long URIs before they have been
  #     spotted.
  # The last two are contradictory.  For now, the code does the first
  # three but not the last.  The perfect solution would be to break long
  # lines and look for URIs and email addresses simultaneuously, but
  # this would mean doing it "by hand", rather than exploiting the
  # esiting URI::Find and Text::Wrap functionality.

  my $wrappedtext = "";
  my $line;
  foreach $line (split(/\n/,$text)) {
    $wrappedtext .= wrap("","",$line) . "\n";
  }
  $text=$wrappedtext;

  $text = escapeHTML($text);

  # Question: should we URI-escape the URI here?  There is no answer,
  # as the URI in the text may already be URI-escaped.  For example,
  # if I want to address a document with a space in the filename, do I
  # write %20?  If I do, I don't want that re-escaped here.
  my $finder = URI::Find->new(sub {
				my($uri, $orig_uri) = @_;
				return qq!<a target="_top" href="$uri">$orig_uri</a>!;
                              });
  $finder->find(\$text);

  # In the following email-grokking regexp, we are not doing
  # URI-escaping on the email address, so weird characters that are
  # valid constituents of an email address but not of a URI - or which
  # have reserved meanings in a URI - are not being escaped.  BUT the
  # regexp to spot the email address doesn't spot these characters in
  # the first place.  What are valid characters in an email address?
  $text =~ s!([-a-zA-Z0-9_+.]+@([-a-zA-Z0-9]+\.)+[A-Za-z]{2,4})!<a target="_blank" onClick="newwin('$scriptbaseuri?action=createmessage;to=$1'); return false;" href="$scriptbaseuri?action=createmessage;to=$1">$1</a>!g;

  return $text;
}


sub html_for_attachment {
  # Return a string of HTML representing an attachment.
  # Creates a link to getattachment.
  # If the attachment is image/something, also put in an IMG tag.
  # TO DO: Use any Content-Description tag.
  my ($uidl,$fn,$type,@partnumbers) = @_;

  my $uri_for_attachment = &get_uri_for_attachment($uidl,@partnumbers);
  my $escaped_fn = escapeHTML($fn);
  my $html = qq!<p>Attachment: <a href="$uri_for_attachment">$escaped_fn</a> ($type)</p>\n!;

  if ($type =~ /^image\//i) {
    $html .= qq!<img src="$uri_for_attachment" alt="$escaped_fn">\n!;
  }

  return $html;
}


sub get_uri_for_attachment {
  # Return the getattachment URI for an attachment given its uidl
  # and partnumbers.
  my ($uidl,@partnumbers) = @_;

  my $attachmentindex = join(",",@partnumbers);
  my $uri_escaped_index = &my_uri_escape($attachmentindex);
  my $uri_escaped_uidl = &my_uri_escape($uidl);

  my $uri = "$scriptbaseuri?action=getattachment;"
    . "uidl=$uri_escaped_uidl;attachmentindex=$uri_escaped_index";
  return $uri;
}



sub make_html_presentable {
  # Take an HTML string from a message and turn it into an HTML string
  # for the web page.
  # There are several ways we could do this.  I have chosen to make
  # the HTML tags visible by escaping them.
  # Alternatives are to pass the HTML formatting through, or to strip
  # the tags.
  # [TO DO We should probably at least make links work]
  # [TO DO worry about the charset]
  my ($html) = @_;

  return "<pre>" . escapeHTML($html) . "</pre>";
}


sub getattachment {
  # Retrieve a message from the POP server and find the specified
  # attachment; close the POP connection; return the attachment to the
  # web browser.
  my ($pop_ref,$uidl,$attachmentindex) = @_;

  my $mimeentity = &get_mimeentity_from_pop($pop_ref,$uidl);
  # We close the POP connection now so that another instance can
  # connect; they don't need to wait for us to send the attachment to
  # the browser.
  $$pop_ref->Close();
  my $attachment = &find_part($mimeentity,$attachmentindex);

  if (!$attachment) {
    die "Can't find specified attachment";
  }

  my $head = $attachment->head();
  my $filename = $head->recommended_filename;

  print CGI::header(-expires => 'now',
		    -cache_control => 'no-cache',
		    -pragma => 'no-cache',
		    -type => $attachment->effective_type(),
		    # content_length =>
		    -content_disposition => "attachment; filename=$filename"
		   );

  $attachment->bodyhandle->print(\*STDOUT);
}


sub find_part {
  # Given a MIME entity, recursively explore it and its sub-parts to
  # find a part based on the index string supplied, and return that part.
  # The index string is a comma-separated list of part numbers, so
  # "1,2" means the second part of the first part of the message.
  my ($mimeentity,$attachmentindex) = @_;

  my @partnumbers = split(/,/,$attachmentindex);

  return &find_part_rec($mimeentity,@partnumbers);
}

sub find_part_rec {
  # Given a MIME entity, recursively explore it and its sub-parts to
  # find a part based on the part numbers supplied, and return that part.
  my ($mimeentity,$thispartnumber,@morepartnumbers) = @_;

  my @parts = $mimeentity->parts();
  my $thispart = $parts[$thispartnumber];

  if (@morepartnumbers) {
    return &find_part_rec($thispart,@morepartnumbers);
  } else {
    return $thispart;
  }
}


sub get_attachment_data {
  # Get the data for an attachment given the UIDL and attachment
  # index.  This is called to retrieve a message's attachments when it
  # is being forwarded.
  my ($pop_ref,$uidl,$attachmentindex) = @_;

  my $mimeentity = &get_mimeentity_from_pop($pop_ref,$uidl);
  my $part = &find_part($mimeentity,$attachmentindex);
  my $body = $part->bodyhandle;
  return $body->as_string();
}


sub replymessage {
  # Create an HTML page for the replymessage action.
  # Gets the To:, Subject: and cited body from the message being
  # replied to, then calls create_common.
  my ($pop_ref,$uidl) = @_;

  my $mimeentity = &get_mimeentity_from_pop($pop_ref,$uidl);
  my $head = $mimeentity->head;
  my $to;
  if ($head->count("reply-to")) {
    $to = $head->get("reply-to");
  } else {
    $to = $head->get("from");
  }
  my $subject;
  if ($head->count("subject")) {
    $subject = $head->get("subject");
  } else {
    $subject = "No subject";
  }
  my $replysubject;
  if ($subject =~ m/^re:/i) {
    $replysubject = $subject;
  } else {
    $replysubject = "Re: $subject";
  }
  my $in_reply_to;
  my $references;
  if ($head->count("references")) {
    $references = $head->get("references");
  } elsif ($head->count("in-reply-to")) {
    $references = $head->get("in-reply-to");
  }
  chomp $references;
  if ($head->count("message-id")) {
    $in_reply_to = $head->get("message-id");
    chomp $in_reply_to;
    if ($references ne "") {
      $references .= " ";
    }
    $references .= $in_reply_to;
  }
  my $orig_to = &get_orig_to($head);
  my $mbody = &get_cited_body("You wrote:",$mimeentity);
  &create_common($to,$orig_to,$replysubject,$in_reply_to,$references,$mbody);
}


sub replyallmessage {
  # Create an HTML page for the replyallmessage action.
  # Gets the To:, Cc:, Subject: and cited body from the message being
  # replied to, then calls create_common.
  my ($pop_ref,$uidl) = @_;

  my $mimeentity = &get_mimeentity_from_pop($pop_ref,$uidl);
  my $head = $mimeentity->head;
  my $from = $head->get("from");
  my @reply_addrs;
  if ($head->count("reply-to")) {
    push @reply_addrs,$head->get("reply-to");
  } else {
    push @reply_addrs,$from;
  }
  my $to;
  foreach $to (split(/,\s*/,$head->get("to"))) {
    push @reply_addrs,$to;
  }
  my $cc;
  foreach $cc (split(/,\s*/,$head->get("cc"))) {
    push @reply_addrs,$cc;
  }
  my $subject;
  if ($head->count("subject")) {
    $subject = $head->get("subject");
  } else {
    $subject = "No subject";
  }
  my $replysubject;
  if ($subject =~ m/^re:/i) {
    $replysubject = $subject;
  } else {
    $replysubject = "Re: $subject";
  }
  my $in_reply_to;
  my $references;
  if ($head->count("references")) {
    $references = $head->get("references");
  } elsif ($head->count("in-reply-to")) {
    $references = $head->get("in-reply-to");
  }
  chomp $references;
  if ($head->count("message-id")) {
    $in_reply_to = $head->get("message-id");
    chomp $in_reply_to;
    if ($references ne "") {
      $references .= " ";
    }
    $references .= $in_reply_to;
  }
  my $orig_to = &get_orig_to($head);
  my $mbody = &get_cited_body("$from wrote:",$mimeentity);
  my $reply_addrs_str = join(", ",@reply_addrs);
  $reply_addrs_str =~ s/\n//g;
  &create_common($reply_addrs_str,$orig_to,$replysubject,$in_reply_to,
		 $references,$mbody);
}


sub get_orig_to {
  # From a header, find the To: or Cc: address that the message was
  # sent to that correspond to this user.
  my ($head) = @_;

  my @recipients;
  my $recipient_header;
  foreach $recipient_header ($head->get_all('to'),$head->get_all('cc')) {
    my $recipient;
    foreach $recipient (split(/,\s*/,$recipient_header)) {
      if ($recipient =~ m/<(.*)>/) {
	push @recipients,$1;
      } else {
	push @recipients,$recipient;
      }
    }
  }

  my @my_recipients=grep(/$my_addrs_re/i,@recipients);
  return $my_recipients[0];
}


sub forwardmessage {
  # Create an HTML page for the forwardmessage action.
  # Gets the Subject: and cited body from the message being
  # replied to, then calls create_common.
  my ($pop_ref,$uidl) = @_;

  my $mimeentity = &get_mimeentity_from_pop($pop_ref,$uidl);
  my $head = $mimeentity->head;
  my $subject;
  if ($head->count("subject")) {
    $subject = $head->get("subject");
  } else {
    $subject = "No subject";
  }
  my $forwardsubject = "Fwd: $subject";
  my $from = $head->get("from");
  my $mbody = &get_cited_body("$from wrote:",$mimeentity);
  my @attachment_codes = &get_attachment_codes($uidl,$mimeentity);
  &create_common("","",$forwardsubject,"","",$mbody,@attachment_codes);
}


sub get_cited_body {
  # Get the text of a message suitable for citing in a reply.  We
  # could repeat the MIME entity recursive parsing code getting text
  # rather than HTML, but it's easier to get the HTML using the
  # existing code and then convert it back to text...
  my ($citation_label,$mimeentity) = @_;

  my $bodytext = &mimeentity_to_html;
  # Remove HTML tags
  $bodytext =~ s/<[^>]+>//g;
  # Decode HTML escapes e.g. &lt;
  $bodytext = unescapeHTML($bodytext);

  my $mbody = "$citation_label\n";
  my $line;
  foreach $line (split(/\n/,$bodytext)) {
    $mbody .= "> $line\n";
  }

  return $mbody;
}


sub get_attachment_codes {
  # Return a list of attachment codes for all the attachments in a
  # message.  This is used to present the list of attachments for
  # possible forwarding.
  my ($uidl,$mimeentity,@partnumbers) = @_;

  if ($mimeentity->is_multipart) {
    my $part;
    my $n = 0;
    my @codes;
    foreach $part ($mimeentity->parts()) {
      push @codes,&get_attachment_codes($uidl,$part,@partnumbers,$n);
      $n++;
    }
    return @codes;
  } else {
    my $type = $mimeentity->effective_type();
    if ($type =~ /^text\/plain/i) {
      return;
    } elsif ($type =~ /^text\/html/i) {
      return;
    } elsif ($type =~ /^message\/rfc822/i) {
      my @parts = $mimeentity->parts();
      return &get_attachment_codes($uidl,$parts[0],@partnumbers,0);
    } else {
      my $attachmentindex = join(",",@partnumbers);
      my $head = $mimeentity->head();
      my $fn = $head->recommended_filename;
      return &make_attachment_code($uidl,$fn,$type,$attachmentindex);
    }
  }
}


sub make_attachment_code {

  my ($uidl,$fn,$type,$attachmentindex) = @_;

  if ($type !~ m#/#) {
      $type .= "/x-unknown";
  }
  return join("/",$type,$attachmentindex,$uidl,$fn);
}


sub decode_attachment_code {

  my ($attachment_code) = @_;

  my ($type,$subtype,$attachmentindex,$uidl,$fn) = split(/\//,$attachment_code,5);
  return ($uidl,$fn,"$type/$subtype",$attachmentindex);
}


sub lookup_msgnum {
  # Given a uidl, find and return the corresponding message number
  my ($pop_ref,$uidl) = @_;

  my @uidls = $$pop_ref->Uidl();

  my $i;
  foreach $i (1 .. $#uidls) {
    if ($uidls[$i] eq $uidl) {
      return $i;
    }
  }
  &errorpage("No message with uidl $uidl");
}


sub lookup_uidl {
  # Given a msgnum, find and return the corresponding uidl
  my ($pop_ref,$msgnum) = @_;

  my $uidl = $$pop_ref->Uidl($msgnum);
  $uidl =~ s/^\d+ //g;
  $uidl =~ s/[\r\n]*$//g;

  return $uidl;
}


sub my_uri_escape {
  # Call URI::Escape's uri_escape
  my ($uri) = @_;

  return uri_escape($uri,"^A-Za-z0-9\-_.!~*()");
  # Note: the character set specified here is the default for newer
  # versions of URI::Escape, but the version I'm using has a
  # different, inferior, default; specifically, it does not escape
  # "?".  Hence this function rather than direct calls to uri_escape.

  # Later note: I have removed ' from the acceptable characters, as
  # mozilla seems to convert it to a uri-escape.
}


sub random_addr {
  # Return a random email address.
  # This is used as one of the options in the From: menu.
  # I use this as an anti-spam measure: once an address gets spammed I
  # can filter it out.
  my $r=&rand_string(5);
  my $a = $rand_addr_template;
  $a =~ s/RAND/$r/g;
  return $a;
}

sub rand_string {
  # Create a string of $chars random characters
  my ($chars)=@_;

  my ($str);

  $str="";
  for (1..$chars) {
    $str.=&rand_char;
  }
  return $str;
}

sub rand_char {
  # Return a random character
  return pack("c",rand(26)+97);
}


sub spam_from {
  # Given an email address, e.g. foo@blah.com, return a "spam from"
  # email address, e.g. spam-from-blah@MY-DOMAIN.
  # This can be used as one of the options in the From: menu, and
  # again I use it as an anti-spam measure.
  my ($addr) = @_;

  if ($addr =~ m/@([^.]*)\./) {
    my $domain1=$1;
    my $spam_from_addr = $spam_from_template;
    $spam_from_addr =~ s/DOMAIN1/$domain1/g;
    return $spam_from_addr;
  } else {
    return "";
  }
}


sub print_qw_init {
  print qq|<script src="qwazerty.js" type="text/javascript" charset="UTF-8"></script>|;
}


sub print_qw_menus {
  print qq|<table><tr>
<td class="prompt">Actual keyboard:</td>
<td>
<script language="javascript" type="text/javascript"><!--
qw_writeoptions("actualkb");
// --></script>
</td>
<td class="prompt">Usual keyboard:</td>
<td>
<script language="javascript" type="text/javascript"><!--
qw_writeoptions("usualkb");
// --></script>
</td>
<td class="prompt">Enable conversion</td>
<td><input type="checkbox" id="convertenabled" name="convertenabled" checked="y"/></td>
</tr>
|;
}


sub print_speller_init {
  print qq|
<script language="javascript" type="text/javascript" src="spellChecker.js">
</script>

<script language="javascript" type="text/javascript">
<!--
function openSpellChecker() {
  var subjtext = document.getElementById("subject");
  var bodytext = document.getElementById("mbody");
  var speller = new spellChecker( subjtext, bodytext );
  speller.openChecker();
}
// -->
</script>
    |;
}


sub showframes {
  print CGI::header(-cache_control => 'public',
		    -type => 'text/html');
  print qq|
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN"
 "http://www.w3.org/TR/html4/frameset.dtd">
<html>
  <head>
    <title>$fullname - Webmail</title>
  </head>
  <frameset rows="33%, 67%">
    <frame name="messagelist" src="$scriptbaseuri?action=listmessages"/>
    <frame name="message"/>
  </frameset>
</html>
    |;
}


sub closewindow {
  print CGI::header(-cache_control => 'public',
		    -type => 'text/html');
  print qq|
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
 "http://www.w3.org/TR/html4/loose.dtd">
<html><head><title>Message Sent</title></head>
<body><script language="javascript" type="text/javascript">
<!--
window.close();
// -->
</script></body></html>
|;
}


sub print_button {
  # Output the HTML for a button.
  # Can be in a new window or replace the current document.
  # Can supply javascript to execute when button is pressed.

  my ($newwin, $url, $label, $onclick_js) = @_;

  my $target_attr;
  if ($newwin) {
    $target_attr = qq| target="_blank"|;
    $onclick_js .= qq|newwin('$url'); return false;|;
  } else {
    $target_attr = "";
    if ($onclick_js) {
      if ($url) {
	$onclick_js .= "return true;";
      } else {
	$onclick_js .= "return false;";
      }
    }
  }

  my $onclick_attr;
  if ($onclick_js) {
    $onclick_attr = qq| onClick="$onclick_js"|;
  } else {
    $onclick_attr = "";
  }

  my $href_attr;
  if ($url) {
    $href_attr = qq| href="$url"|;
  } else {
    $href_attr = qq| href="$url"|;
  }

  print qq|<a class="button"$target_attr$onclick_attr$href_attr>$label</a>|;
}


sub print_action_button {
  # Print HTML for a button to invoke this script.

  my ($newwin, $button_text, $action, $uidl,
      $next_action, $next_uidl, $onclick_js) = @_;

  my $link = "$scriptbaseuri?action=$action";
  if ($uidl) {
    $link .= ";uidl=$uidl";
  }
  if ($next_action) {
    $link .= ";next_action=$next_action";
  }
  if ($next_uidl) {
    $link .= ";next_uidl=$next_uidl";
  }

  &print_button($newwin,$link,$button_text,$onclick_js);
}


sub print_js_button {
  # Print HTML for a button that only invokes a javascript operator

  my ($button_text, $onclick_js) = @_;

  &print_button(0,"",$button_text,$onclick_js);
}


sub print_shared_js {
  # Print javascript code shared by all windows

  print qq|function newwin(url) {window.open(url,'_blank','scrollbars,width=750,height=970');}
|;
}




# The following paragraphs document one of the more cryptic aspects of
# the code, in case I forget how it works.  Users don't need to worry
# about this stuff.

# Indicating attachments

# In various situations it is necessary to indicate a particular
# attachment; for example, when creating an IMG tag in a view of a
# message, the SRC attribute gives an action=getattachment URI that
# has to indicate which of the message's attachments to return.
# "Attachment indices" are used for this.

# An attachment index is a comma-separated list of numbers - though
# typically it will be a 1-element list.  For a flat multipart message
# the index is the number of the MIME part containing the attachment,
# counting from the start of the message at zero.  When the MIME
# structure is not flat, such as when a message with attachments has
# been forwarded as an attachment, the elements of the attachment
# index indicate a path to the attachment part.

# To generate attachment indicies, list of part numbers are passed
# around, with a number occasionally added, and then joined with
# commas.


# Forwarding attachments

# If you forward a message that has attachments, you can choose
# whether or not to forward them.  To do this an attachment code is
# formed for each attachment, and checkboxes in the message
# composition form return a set of these codes indicating which
# attachments the user wishes to forward.  These codes indicate the
# forwarded message's UIDL, the attachment index, the MIME type, and
# the filename, all of which are needed for forwarding.  The codes are
# formed by joining these elements with /s.