#!/usr/bin/perl -w $| = 1; # Phil's Webmail # http://chezphil.org/pwebmail/ # Scroll down about 100 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 Library 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. # Reply-to-all doesn't work properly; it only includes people who were # cc'd in the original message, not people who were also in the to: # line. # Ought to do something about in-reply-to: and refereces: headers so that # threading works. # Clicking on an email address in a message opens a composition # window, but in the same frame, not in a popup. # The from: address menu doesn't set the corresponding text entry when # used with Internet Explorer (javascript problem?). # 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. 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 # ---------------------------------------------------- # 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"; # 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. # ------------------------------- $MAIN::POPAUTHMODE = "BEST"; 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 $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, $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 => $MAIN::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!

$msg

!; &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,$mbody,@attachment_codes) = @_; $to = escapeHTML($to); $subject = escapeHTML($subject); $mbody = escapeHTML($mbody); &print_header(1,"compose"); print qq!
!; 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|
|; &print_js_button("Clear body","clearbody();"); if ($use_speller) { &print_js_button("Check Spelling","openSpellChecker();"); } print qq|
From:
To:
Cc:
Bcc:
ReplyTo:
Subject:
|; if ($use_qwazerty) { &print_qw_menus(); } print qq| |; # 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! !; } print qq!
Attachment 1:
Attachment 2:
Attachment 3:
Attachment 4:
Attachment 5:
Forwarded attachment: !; print &html_for_attachment($uidl,$fn,$type,@partnumbers); print qq!
!; } 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@
@; 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|
|; &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|
|; print qq| |; $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|
FromSubjectDateSize
|; } 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||; print qq! $readlink$from $readlink$subject $readlink$dateofmess $readlink$sizeofmess !; $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, Bill" # 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, $attachment1,$attachment2,$attachment3,$attachment4,$attachment5, @attachattachments) = @_; chomp($to,$from,$mbody,$replyto,$subject,$cc,$bcc, $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 $msg = MIME::Lite->new(From => $from, To => join(', ', @to), Cc => join(', ', @cc), 'Reply-To' => $replyto, Subject => $subject, Date => $date, 'X-Mailer' => "Phil's WebMail", Type => "TEXT", Data => $mbody ); 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 = ; 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!\n!; print qq!\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 "

Ooops - changed our minds about cacheability

\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| $fullname - Webmail |; } sub readmessage { # Output an HTML page for a message. my ($pop_ref,$uidl,$showheaders) = @_; &print_header(1); my $idsubstr = &get_idsubstr($uidl); print qq| |; 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|
|; &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!
\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!
! . $header_html . $body_html . "
\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!
! . &text_to_html($text) . "
\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!!; foreach $header_name ("Subject","Date","From","To","Cc","Reply-to") { my @headers = $mimeentity->head()->get($header_name); if (@headers) { chomp @headers; $html .= qq!!; } } $html .= qq!
! . $header_name . qq!:! . &text_to_html(join(", ",@headers)) . qq!
!; 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!

No acceptably-typed entity in multipart/alternative\n! . "Types are: " . join(', ',@types) . "

\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 "
" . &text_to_html($text) . "
"; } 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!$orig_uri!; }); $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})!$1!g; # !!! This needs to be updated so that the composition window is a # !!! new window. 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!

Attachment: $escaped_fn ($type)

\n!; if ($type =~ /^image\//i) { $html .= qq!$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 "
" . escapeHTML($html) . "
"; } 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 $orig_to = &get_orig_to($head); my $mbody = &get_cited_body("You wrote:",$mimeentity); &create_common($to,$orig_to,$replysubject,$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 $orig_to = &get_orig_to($head); my $mbody = &get_cited_body("$from wrote:",$mimeentity); &create_common(join(", ",@reply_addrs),$orig_to,$replysubject,$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. < $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||; } sub print_qw_menus { print qq| |; } sub print_speller_init { print qq| |; } sub showframes { print CGI::header(-cache_control => 'public', -type => 'text/html'); print qq| $fullname - Webmail |; } sub closewindow { print CGI::header(-cache_control => 'public', -type => 'text/html'); print qq| Message Sent |; } 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|$label|; } 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,'Webmail','scrollbars,width=750,height=970');} |; }
Actual keyboard: Usual keyboard: Enable conversion