WEB邮件程序

开发平台：
Perl

getmsg.pl：源码内容
							#!/usr/local/bin/perl
BEGIN { $APP_PATH=$0; $APP_PATH=~s/(/*)[^/]+$/$1/g; }
# @ ----------------------------------------------------------------------------------------------------------
# @ This code is (c) 1999 Alexandre Aufrere and NikoSoft.
# @ Published under NPL rights, meaning you have the right
# @ to use and modify this code freely, provided it 
# @ remains available and free. Any modified code should be
# @ submitted to Nikopol Software Corp. or Alexandre Aufrere.
# @ This code is protected by the French laws on Copyright.
# @ Please note that there it comes with NO WARRANTY of any kind,
# @ and especially for any damagbe it could cause to your computer
# @ or network.
# @ Using this code means you agree to this license agreement.
# @ Further information at http://nikosoft.free.fr/
# @ ----------------------------------------------------------------------------------------------------------
# @ 
# @ Project		NS WebMail
# @ 
# @ Filename		getmsg.pl
# @ 
# @ Description	view messages using POP protocol.
# @ 
# @ Version		0.6
# @ 
# @ ----------------------------------------------------------------------------------------------------------
use Mail::POP3Client;
use MIME::Parser;
use CGI::Carp qw(fatalsToBrowser);
require $APP_PATH."config.pl";
require $APP_PATH."common.pl";
#obtain the FORM information that has been passed by using
#the param() method of the cgi object.
&ReadParse;
$loginname =  $in{'loginname'};
$password =   $in{'password'}; # encrypted password !!!
$POPserver =  $in{'POPserver'};
$msgid =      $in{'id'};
$cache     =  $in{'cache'};
$browser = $ENV{'HTTP_USER_AGENT'};
$|=1;
#clear the $body variable.
$body ="";
#create a POP connection using the POP3client module by
#creating an object called $pop of type POP3Client. See
#POP3Client.pm documentation.
$pop = new Mail::POP3Client( USER=>$loginname,
			PASSWORD=> decryptit($password),
			HOST=>$POPserver,
			AUTH_MODE=>$POPauth
			);
$MessageCount = $pop->Count;
print "Content-type: text/htmlnn";
print "<HTML><HEAD><TITLE>NSC WebMail";
print "</TITLE>";
if ($cache eq "No") {	print "<META HTTP-EQUIV='Pragma' CONTENT='no-cache'>"; }
if ($browser =~ /Mozilla/2/) {
	print "<SCRIPT LANGUAGE='JavaScript'><!-- Hide JavaScript from old browsersn";
	print "function goBack()n";
	print "{n";
	print "history.go(-1)n";
	print "}n";
	print "//---- End hiding JavaScript --></SCRIPT>n";
}
print "</HEAD>";
print "<BODY BGCOLOR='FFFFFF'>";
#print "<font size='+2'>Message $msgid</font>";
$message="";
foreach ($pop->HeadAndBody($msgid)) {
	$message.=$_."n";	
}
my $parser = new MIME::Parser;
$parser->output_dir($temppath);
$parser->output_prefix("msg$msgid");
my $entity = $parser->parse_data($message);
# Get the head, a MIME::Head:
my $head = $entity->head;
$head->unfold;
$head->decode();
$from=$head->get('from');
$from=~ s/"//g;
$replyto=$head->get('reply-to');
$replyto=~ s/"//g;
$to=$head->get('To');
$to=~ s/"//g;
$cc=$head->get('cc');
$cc=~ s/"//g;
$date=$head->get('date');
$sub=$head->get('subject');
my $messagestored="";
my $bodysend="";
undef @attach;
if ($entity->parts) {
	for ($i=0;$i<$entity->parts;$i++) {   
		$ent=$entity->parts($i);  
		$type = lc($ent->mime_type);
		# Get the body, as a MIME::Body;
		$body = $ent->bodyhandle;
		if ($body) {
			# Where's the data?
			if ($type=~ m/text/) {
				if ($type=~ m/text/plain/) {
					$messagestored.="<hr>" if ($i > 0);
					$messagestored.="<pre>";
	                $messagestored.= htmlize($body->as_string);
					$messagestored.="</pre>";
 				}
				elsif ($type=~ m/text/html/) {
					$messagestored.= $body->as_string;
				}
				$bodysend.=substr($body->as_string,0,1000);
				$ent->purge;
			} elsif ($type=~ m/image//) {
					$messagestored.="<hr>" if ($i > 0);
					$messagestored.="<br><img src="";
					my $path = $body->path;
					$bodysend.="n[ $path ]n";
					$path=~ s/$temppath/?(.*)/$tempurl/$1/;
					$messagestored.="$path">";
					push @attach,$path;
			} else {   # data is on disk:
				my $path = $body->path;
				$path=~ s/$temppath/?(.*)/$tempurl/$1/;
				push @attach,$path;
			}    
		}
		# we may have multipart included inside multipart
		elsif ($type =~ m/multipart/) {
			my $entityinside = $ent;
			if ($entityinside->parts) {
				for ($j=0;$j<$entityinside->parts;$j++) {
        			$entin=$entityinside->parts($j);
			        $typein = lc($entin->mime_type);
			        # Get the body, as a MIME::Body;
			        $bodyin = $entin->bodyhandle;
					$messagestored.="<pre>".htmlize($bodyin->as_string)."</pre>" if ($typein =~ m/text/plain/);
 					$messagestored.=$bodyin->as_string if ($typein =~
m/text/html/);
					$bodysend.=substr($bodyin->as_string,0,1000) if
(!$bodysend);
				}
			}
		}
	}   
} else {
	$body = $entity->bodyhandle;
	if (lc($entity->mime_type)=~ m/text/plain/) {
		$messagestored.="<pre>";
	}
	$messagestored.= htmlize($body->as_string);
	if (lc($entity->mime_type)=~ m/text/plain/) {
		$messagestored.="</pre>";
	}
	$bodysend.=substr($body->as_string,0,1000);
	$entity->purge;	
}
print "<center><TABLE border=0><TR>";
$msg_prev=$msg_next=$msgid;
if ($msgid > 1) { $msg_prev = $msgid-1;  }
if ($msgid < $MessageCount) { $msg_next = $msgid+1; }
if ($msg_prev != $msgid) {
	print "<TD><FORM METHOD='POST'  ACTION='".$CGI_PATH_NSWM."getmsg.pl' NAME='lire$msg_prev'>n";
	print "<INPUT TYPE='submit'			VALUE='&lt;'>n";
	print "<INPUT TYPE='hidden' NAME='id'		VALUE=$msg_prev	>n";
	print "<INPUT TYPE='hidden' NAME='loginname'	VALUE=$loginname   >n";
	print "<INPUT TYPE='hidden' NAME='password'	VALUE=$password    >n";
	print "<INPUT TYPE='hidden' NAME='POPserver'	VALUE=$POPserver   >n";
	print "<INPUT TYPE='hidden' NAME='cache'	VALUE=$cache    >n";
	print "</FORM></TD>";
}
print "<TD valign=center><font size='+1'># $msgid</font></TD>";
if ($msg_next != $msgid) {
	print "<TD><FORM METHOD='POST'  ACTION='".$CGI_PATH_NSWM."getmsg.pl' NAME='lire$msg_next'>n";
	print "<INPUT TYPE='submit'			VALUE='&gt;'>n";
	print "<INPUT TYPE='hidden' NAME='id'		VALUE=$msg_next	>n";
	print "<INPUT TYPE='hidden' NAME='loginname'	VALUE=$loginname   >n";
	print "<INPUT TYPE='hidden' NAME='password'	VALUE=$password    >n";
	print "<INPUT TYPE='hidden' NAME='POPserver'	VALUE=$POPserver   >n";
	print "<INPUT TYPE='hidden' NAME='cache'	VALUE=$cache    >n";
	print "</FORM></TD>";
}
# Now create a button which will enable a user to generate a reply.
# As usual, the button is loaded with hidden values to permit a message
# to actually be sent at a later time.
if ($replyto == '') { $replyto = $from;  }
print "<TD ALIGN=CENTER>n";
print "<FORM METHOD='POST' ACTION='".$CGI_PATH_NSWM."sendform.pl' name=reMailForm>n";
print "<INPUT TYPE='submit'                       VALUE='$answertext'>n";
print "<INPUT TYPE='hidden'  NAME='loginname'     VALUE=$loginname>n";
print "<INPUT TYPE='hidden'  NAME='password'      VALUE=$password>n";
print "<INPUT TYPE='hidden'  NAME='POPserver'     VALUE=$POPserver>n";
print "<INPUT TYPE='hidden'  NAME='to'            VALUE="",he($replyto),"">n";
print "<INPUT TYPE='hidden'  NAME="subject"       VALUE="",he("Re: $sub"),"">n";
print "<INPUT TYPE='hidden'  NAME='body'          VALUE="",he($bodysend),"">n";
print "<INPUT TYPE='hidden'  NAME='cache'         VALUE=$cache>n";
print "</FORM></TD>n";
print "<TD ALIGN=CENTER>n";
print "<FORM METHOD='POST' ACTION='".$CGI_PATH_NSWM."sendform.pl' name=fwdMailForm>n";
print "<INPUT TYPE='submit'                       VALUE='$fwdtext'>n";
print "<INPUT TYPE='hidden'  NAME='loginname'     VALUE=$loginname>n";
print "<INPUT TYPE='hidden'  NAME='password'      VALUE=$password>n";
print "<INPUT TYPE='hidden'  NAME='POPserver'     VALUE=$POPserver>n";
print "<INPUT TYPE='hidden'  NAME='to'            VALUE="">n";
print "<INPUT TYPE='hidden'  NAME="subject"       VALUE="",he("Fwd: $sub"),"">n";
print "<INPUT TYPE='hidden'  NAME='body'          VALUE="",he($bodysend),"">n";
print "<INPUT TYPE='hidden'  NAME='cache'         VALUE=$cache>n";
print "</FORM></TD>n";
#for each message header, also provide a FORM button to
#delete using inbox.pl As above, pass in the needed vars
#using hidden types.
print "<TD ALIGN=CENTER>n";
print "<FORM METHOD='POST' ACTION='".$CGI_PATH_NSWM."inbox.pl'>n";
print "<INPUT TYPE='submit'                   VALUE='$deletetext' OnClick="return confirm('$deleteconfirmtext');"  >n";
print "<INPUT TYPE='hidden' NAME='loginname'  VALUE=$loginname >n";
print "<INPUT TYPE='hidden' NAME='password'   VALUE=$password  >n";
print "<INPUT TYPE='hidden' NAME='POPserver'  VALUE=$POPserver >n";
print "<INPUT TYPE='hidden' NAME='deleteMsg'  VALUE=$msgid         >n";
print "<INPUT TYPE='hidden' NAME='cache'      VALUE=$cache  >n";
print "</FORM></TD></TR></TABLE>";
$from=he($from);
$to=he($to);
$cc=he($cc);
print "</center><table border=0 width=100%><tr bgcolor=lightblue><td><font face=arial><ul>";
print "$totext: $to <br>n";
print "Cc: $cc <br>n" if ($cc ne"");
print "$fromtext: <b>$from</b><br>n";
print "$subjecttext: <b>$sub</b>  <br>n";
$date=~ s/.*,(.*)+.*/$1/;
print "$datetext: $date <br>n";
if (defined(@attach)) {
	print "$attachtext:<ol>";
	foreach $attach (@attach) {
		my $file=$attach; $file=~s/$tempurl///;
		$size = (stat("$temppath/$file"))[7];
		print "<li><a href="$attach" target=_blank>$file</a> ",int(($size+512)/1024)."kn";
	}
	print "</ol>";
}
print "</ul></font></td></tr></table>";
print "<br><font face=times size=+1>";
print $messagestored;
#close the POP connection using the close() method
$pop->Close();
#send the ending html code (/body and /head tags)
print "</BODY></HTML>n";
exit;
#-----------------------------SUBROUTINES------------------------
sub decodeHexChars {
	($text)=@_;
	for ($t=0; $t<=length($text); $t++) {
		if (substr($text, $t, 1) eq "=") {
			$char=chr(hex(substr($text,$t+1,2)));
			substr($text,$t,3,$char);
		}
	}
	return $text;
}
sub ReadParse {
	local(*in)=@_ if @_;
	local ($i,$key,$val);
	
	if ($ENV{'REQUEST_METHOD'} eq "GET") {
			$in=$ENV{'QUERY_STRING'};
	}
	elsif ($ENV{'REQUEST_METHOD'} eq "POST") {
			read(STDIN,$in,$ENV{'CONTENT_LENGTH'});
	}
	
	@in=split(/&/,$in);
	
	foreach $i (0 .. $#in) {
			$in[$i] =~ s/+/ /g;
		($key,$val)=split(/=/,$in[$i],2);
		$key =~ s/%(..)/pack("c",hex($1))/ge;
		$val =~ s/%(..)/pack("c",hex($1))/ge;
		$in{$key} .= "" if (defined($in{$key}));
		$in{$key} .=$val;
	}
	return length($in);
}
sub htmlize {
my ($line,$out);
foreach $line (@_) {
# order of following lines is dependent!
# char < and >
$line=~s,<, &lt; ,g;
$line=~s,>, &gt; ,g;
# e-mail
$line=~s,(wS+@S+w).*,<a href="mailto:$1">$1</a>,g;
# http and ftp
$line=~s,(h*[t|f]tp://[^)|s|,]+w[^.s])([).]*),<a href="$1">$1</a>$2,g;
# quoting (in color!)
$line=~s,^( &gt; s*.*),<font color="#666666"><i>$1 </i></font>,;
$line=~s,^(:s+.*),<font color="#666666"><i>$1</i></font>,;
# nuke spaces around &lt; | &gt;
$line=~s, (&[l|g]t;) ,$1,g;
$out.=$line;
}
return $out;
}
sub he {	# HtmlEscape
	my ($line,$out);
	foreach $line (@_) {
		$line=~s/</&lt;/g;
		$line=~s/>/&gt;/g;
		$line=~s/"/&quote;/g;
		$out.=$line;
	}
	return $out;
}
##############################
#  GetHeader Subroutine      #
##############################
sub GetHeader {
	
  #for the message identified by the 'id'
  #passed in the FORM, POP the header to
  #get the 'Subject' and 'From' info. Why? Because if the
  #are passed in the header and one is greater than 256 characters
  #the browser will chop it off.
  #This is unlikely, but we want to cover any
  #eventuality.
  my @headers=$pop->Head($msgid);
  while ($_ = shift @headers) {
    #parse out the From line from the header.
    #Also, remove any angle brackets
    #since some SMTP servers choke on these, but
    #some POP clients send them anyway.  (Not to mention
    #but browsers tend to ignore them as unknown
    #HTML codes.
    if (/^From:/ ){
      $from = $_;				#assign the targeted line to the variable
      $from =~ s/From:s+//;  #remove leading "From:" and any following whitespace
      $from =~s/"//g;		#remove any quote marks & match contents
      if ($from =~/<(.*@.*)>/) { #delete angle brackets & match anything inside w/ "@"
	$from2 = $1;	    #use electronic address, if available
      }
      else {
	$from2 = $from;	    #else, use the quoted name
      }
    }# end if From
		
    #parse out the "reply-to" line, if it exists...
    $replyto = '';			#create the variable, but leave it empty
    if (/^Reply-To:/) {
      $replyto = $';
      $replyto =~ s/s+//;	#remove intervening white space
      $replyto =~ s/</&lt;/;	  #make angle brackets browser safe
      $replyto =~ s/>/&gt;/;
    }
		
		
    
    #parse out the subject line.
    if  (/^Subject:/) {
      #once the target phrase is found,
      #capture everything following it with the
      # $' PERL system function.
      $sub = $';
      $sub =~ s/s+//;   #remove leading white space
    }
    
    #parse out the date line.
    if  (/^Date:/) {
      #once the target phrase is found,
      #capture everything following it with the
      # $' PERL system function.
      $date = $';
      $date =~ s/s+//;   #remove leading white space
    }
    if  (/^Content-Type:/) {
      #once the target phrase is found,
      #capture everything following it with the
      # $' PERL system function.
      $ctype = $';
      $ctype =~ s/s+//;   #remove leading white space
    }
    if  (/boundary=/) {
      #once the target phrase is found,
      #capture everything following it with the
      # $' PERL system function.
      $bound = $';
      $bound =~ s/"(.*)"/$1/;   #remove leading white space
    }
    #parse out the recipient line.
    if (/^To:/) {
      #once the target phrase is found,
      #capture everything following it with the
      # $' PERL system function.
      $to = $';
      $to =~ s/s+//;   	  #remove leading white space
      #support for multi-line To:
      while ($headers[0] =~ m/^ +/) {
	my $tmp = shift @headers;
	$tmp =~ s/s+//;
	$to .= $tmp;
      }
      $to =~ s/</&lt;/g;	  #make angle brackets browser safe
      $to =~ s/>/&gt;/g;      
    }
    #parse out the recipient line.
    if ((/^CC:/)||(/^Cc:/)) {
      #once the target phrase is found,
      #capture everything following it with the
      # $' PERL system function.
      $cc = $';
      $cc =~ s/s+//;   	  #remove leading white space
      $cc =~ s/</&lt;/;	  #make angle brackets browser safe
      $cc =~ s/>/&gt;/;      
    }
  }
}

						