WEB邮件程序

开发平台：
Perl

send.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 damage 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		send.pl
# @ 
# @ Description		sends mail using SMTP protocol. the mail sender
# @ 				is authentified through POP, preventing this script
# @ 				from beeing used for bomb mailing and so on.
# @ 
# @ Version		1.0
# @ 
# @ ----------------------------------------------------------------------------------------------------------
use Socket;
use Mail::POP3Client;
use MIME::Lite;
use CGI; # required due to file upload needs
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.
my $query = new CGI;
$loginname = $query->param("loginname");
$password  = $query->param("password");
$POPserver = $query->param("POPserver");
$sender    = $query->param("sender");
$to        = $query->param("to");
$cc        = $query->param("cc");
$subject   = $query->param("subject");
$message   = $query->param("message");
$cache     = $query->param("cache");
# POP connexion to authentify sender
my $pop = new Mail::POP3Client( USER=>$loginname, 
							PASSWORD=> decryptit($password), 
							HOST=>$POPserver,
				            AUTH_MODE=>$POPauth
							);
my $MessageCount = $pop->Count;
$pop->Close();
if ($MessageCount == -1) {
	print "<font size=+1>$POPserver: $loginname, $incorrectlogin";
	exit;
	}
# sending the mail using sendmail function
# the apparently-from field  is made using login and POP server, but the
# from and reply-to fields are specified by the sender in the from field
#output the header to the client browser (DO NOT DELETE).
#lack of this will result in an error 500.
print "Content-type: text/htmlnn";
print "<HTML><HEAD><TITLE>NSWM - Message sent</TITLE>";
if ($cache eq "No") { print "<META HTTP-EQUIV='Pragma' CONTENT='no-cache'>"; }
# file upload
if ($query->param("file") ne "") {
	my $file = $query->param("file");
	my $bytesread;
	my $buffer;
	my $tmpfilename="$temppath/upload".(localtime)[0].(localtime)[1].".tmp";
	# writing file on disk
	open (OUTFILE,">$tmpfilename");
	binmode(OUTFILE);
	while ($bytesread=read($file,$buffer,1024)) {
		print OUTFILE $buffer;
	}
	close OUTFILE;
	
	my $filename=$file;
	$filename =~ s/.*\(.*)$/$1/i;
	my $fullqfn=$tmpfilename;
	# MIME Type detection
	my $mime_filetype="";
	$mime_filetype = "image/jpg" if ($filename =~ m/.*jpg$/i);
	$mime_filetype = "image/gif" if ($filename =~ m/.*gif$/i);
    $mime_filetype = "image/png" if ($filename =~ m/.*png$/i);
	$mime_filetype = "application/msword" if ($filename =~ m/.*doc$/i);
	$mime_filetype = "application/rtf" if ($filename =~ m/.*rtf$/i);
	$mime_filetype = "application/x-zipped-compressed" if ($filename =~ m/.*zip$/i);
	$mime_filetype = "application/pdf" if ($filename =~ m/.*pdf$/i);
	$mime_filetype = "application/vnd.ms-powerpoint" if ($filename =~ m/.*ppt$/i);
	$mime_filetype = "application/vnd.ms-excel" if (($filename =~ m/.*xls$/i)||($filename =~ m/.*xlt$/i));
    $mime_filetype = "application/octet-stream" if ($filename =~m/.*exe$/i);
    $mime_filetype = "application/x-tar" if ($filename =~m/.*tar$/i);
    $mime_filetype = "application/x-gzip" if ($filename =~m/.*gz$/i);
    $mime_filetype = "text/x-vcard" if ($filename =~m/.*vcf$/i);
    $mime_filetype = "audio/x-wav" if ($filename =~m/.*wav$/i);
    $mime_filetype = "video/mpeg" if ($filename =~m/.*mpg$/i);
	if ($mime_filetype eq "") {
		print "$mimetypenotdetected $filename.n";
		exit;
	}
	# Building Mail Message
	my $msg = new MIME::Lite
				Type	=>'multipart/mixed';	
	attach $msg
				Type	=>'TEXT',
				Data	=>$message;
	attach $msg
				Type	=>$mime_filetype,
				Path	=>$fullqfn,
				Encoding	=>"base64",
				Filename	=>$filename;
	$message = $msg->as_string;
	$message =~ s/X-Mailer.*n//;
	unlink($tmpfilename);
}
else {
  $message="rn".$message;
}
$status = sendmail($loginname."@".$POPserver, $sender, $sender,  $to, $cc, $SMTPserver, $subject, $message);
$date=localtime();
# in case of success, we redirect to the inbox
print "<META HTTP-EQUIV="Refresh" CONTENT="5;URL='inbox.pl?loginname=$loginname&POPserver=$POPserver&cache=$cache&password=$password'">" if ($status==1);
print "</HEAD><BODY BGCOLOR='FFFFFF'>";
print "<br><ul><h3>";
if    ($status ==  1) {
	$logfilename=$LOG_PATH.$loginname."@".$POPserver.".log";
	print $messagesent;
	open (f, ">>$logfilename");
	print f $date.";".$to.";".$subject."n";
	close (f);
} 
elsif ($status == -1) {print " $smtp : $smtphostunkown";}
elsif ($status == -2) {print $createsocketfailed;}
elsif ($status == -3) {print $connectionfailed;}
elsif ($status == -4) {print $servicena;}
elsif ($status == -5) {print $commerror;}
elsif ($status == -6) {print " $to ($smtp): $userunkown.";}
elsif ($status == -7) {print " $transfailed.";}
elsif ($status == -8) {print " $notofield";}
else {print " $errorunkown.";}
print "</h3></ul><br>";
#send the ending html code (/body and /head tags)
print "</BODY></HTML>";
exit;
#-----------------------------SUBROUTINES------------------------
#------------------------------------------------------------
# sub sendmail()
#
# send/fake email around the world ...
#
# Version : 1.21
# Environment: Hip Perl Build 105 NT 3.51 Server SP4
# Environment: Hip Perl Build 110 NT 4.00
#
# arguments:
#
# $afrom apparently-from email address of sender
# $from email address of sender
# $reply email address for replying mails
# $to email address of reciever
# (multiple recievers can be given separated with space)
# $smtp name of smtp server (name or IP)
# $subject subject line
# $message (multiline) message
#
# return codes:
#
# 1 success
# -1 $smtphost unknown
# -2 socket() failed
# -3 connect() failed
# -4 service not available
# -5 unspecified communication error
# -6 local user $to unknown on host $smtp
# -7 transmission of message failed
# -8 argument $to empty
#
# usage examples:
#
# print
# sendmail("Alice <alice@company.com>",
# "alice@company.com",
# "joe@agency.com charlie@agency.com",
# $smtp, $subject, $message );
#
# or
#
# print
# sendmail($from, $reply, $to, $smtp, $subject, $message );
#
# (sub changes $_)
#
#------------------------------------------------------------
################################################################
### sendmail ###################################################
################################################################
sub sendmail {
my ($afrom,$from, $reply, $to, $cc, $smtp, $subject, $message) = @_;
$date=localtime();
my $fromaddr = $from; chomp $fromaddr; chomp $from;
my $replyaddr = $reply; chomp $replyaddr; chomp $reply; 
$to =~ s/[ t]+/, /g if ($to !~ m/</); # pack spaces and add comma (if email not in John Doe <John.Doe@somewhere.com> format)
$cc =~ s/[ t]+/, /g if ($cc !~ m/</); # pack spaces and add comma
$fromaddr =~ s/.*<([^s]*?)>/$1/; # get from email address
$replyaddr =~ s/.*<([^s]*?)>/$1/; # get reply email address
$replyaddr =~ s/^([^s]+).*/$1/; # use first address
$message =~ s/^./../gm; # handle . as first character
$message =~ s/rn/n/g; # handle line ending
$message =~ s/n/rn/g;
$smtp =~ s/^s+//g; # remove spaces around $smtp
$smtp =~ s/s+$//g;
if (!$to) { return -8; }
my($proto) = (getprotobyname('tcp'))[2];
my($port) = (getservbyname('smtp', 'tcp'))[2];
my($smtpaddr) = ($smtp =~
/^(d{1,3}).(d{1,3}).(d{1,3}).(d{1,3})$/)
? pack('C4',$1,$2,$3,$4)
: (gethostbyname($smtp))[4];
if (!defined($smtpaddr)) { return -1; }
if (!socket(S, AF_INET, SOCK_STREAM, $proto)) { return -2; }
if (!connect(S, pack('Sna4x8', AF_INET, $port, $smtpaddr))) { return -3; }
my($oldfh) = select(S); $| = 1; select($oldfh);
$_ = <S>; if (/^[45]/) { close S; return -4; }
print S "helo localhostrn";
$_ = <S>; if (/^[45]/) { close S; return -5; }
print S "mail from: <$fromaddr>rn";
$_ = <S>; if (/^[45]/) { close S; return -5; }
foreach (split(/, /, $to)) {
  chomp;
  $tmpto=$_;
  $tmpto =~ s/.*<([^s]*?)>/$1/;
  $tmpto =~ s/,//g;
  print S "rcpt to: <$tmpto>rn";
  $_ = <S>; if (/^[45]/) { close S; return -6; }
}
foreach (split(/, /, $cc)) {
  chomp;
  $tmpcc=$_;
  $tmpcc =~ s/.*<([^s]*?)>/$1/;
  $tmpto =~ s/,//g;
  print S "rcpt to: <$tmpcc>rn";
  $_ = <S>; if (/^[45]/) { close S; return -6; }
}
print S "datarn";
$_ = <S>; if (/^[45]/) { close S; return -5; }
print S "To: $torn";
if ($cc ne "") { print S "CC: $ccrn"; }
print S "From: $fromrn";
print S "Reply-to: $replyaddrrn" if $replyaddr;
print S "Apparently-from: $afromrn";
print S "X-Mailer: NikoSoft WebMail Perl from Alexandre Aufrerern";
print S "Date: $datern";
print S "Subject: $subjectrn";
print S "$message";
print S "rn.rn";
$_ = <S>; if (/^[45]/) { close S; return -7; }
print S "quitrn";
$_ = <S>;
close S;
return 1;
}

						