发邮件的PERL/Tk脚本

#!c:/perl/bin/perl.exe

#   jondy

#   http://blog.csdn.net/jondynetuse strict;
use Tk;

my $mainbg = "sendmail.dat";

my $main = new MainWindow;
$main->title('Perl SendMail 1.0;');
$main->geometry("39x24");
if (-e "sendmail.dat") {}
else{
&MsgShow('OK','Warning',"SendMail.BMP没找到，请重新安装！","error");
exit;
}
$main->Photo('main_bg', -file => "$mainbg");
$main->Label(-image => 'main_bg')->pack(-side=>'left',-anchor=>'n');
$main->Label(-text => 'Perl SendMail 1.0 , Desgined by jondy;',-width=>30)->place(-x=>128,-y=>95);
$main->Label(-text => '服务器:',-font=>'{MS Sans Serif} 10 {normal}',-relief=>'groove')->place(-x=>10,-y=>115);
my $host = $main->Entry(-width => 34,-relief=>'groove',-font=>'{MS Sans Serif} 10 {normal}');
$host->place(-x=>62,-y=>115);
$main->Label(-text => '用户名:',-font=>'{MS Sans Serif} 10 {normal}',-relief=>'groove')->place(-x=>10,-y=>140);
my $user = $main->Entry(-width => 13,-relief=>'groove',-font=>'{MS Sans Serif} 10 {normal}');
$user->place(-x=>62,-y=>140);
$main->Label(-text => '密 码:',-font=>'{MS Sans Serif} 10 {normal}',-relief=>'groove',width=>6)->place(-x=>160,-y=>140);
my $pass = $main->Entry(-width => 13,-show =>'*',-relief=>'groove',-font=>'{MS Sans Serif} 10 {normal}');
$pass->place(-x=>209,-y=>140);
$main->Label(-text => '发信人:',-font=>'{MS Sans Serif} 10 {normal}',-relief=>'groove')->place(-x=>10,-y=>165);
my $from = $main->Entry(-width => 13,-relief=>'groove',-font=>'{MS Sans Serif} 10 {normal}');
$from->place(-x=>62,-y=>165);
$main->Label(-text => '收信人:',-font=>'{MS Sans Serif} 10 {normal}',-relief=>'groove')->place(-x=>160,-y=>165);
my $to = $main->Entry(-width => 13,-relief=>'groove',-font=>'{MS Sans Serif} 10 {normal}');
$to->place(-x=>209,-y=>165);
$main->Label(-text => '主 题:',-font=>'{MS Sans Serif} 10 {normal}',-relief=>'groove',width=>6)->place(-x=>10,-y=>190);
my $subject = $main->Entry(-width => 34,-relief=>'groove',-font=>'{MS Sans Serif} 10 {normal}');
$subject->place(-x=>62,-y=>190);
my $body=$main->Scrolled(qw/Text -relief groove -scrollbars e -wrap word -width 39 -height 6 -setgrid 1/,-font=>'{MS Sans Serif} 10 {normal}')->place(-x=>10,-y=>215);
$main->Button(-text => '发 送',-width=>'8',-relief=>'ridge',
-font=>'{Arial} 10 {bold}',-command => sub{do_send($host,$user,$pass,$from,$to,$subject,$body)},
-activebackground=>'white')->place(-x=>10,-y=>322);
$main->Button(-text => '清 空',-activebackground=>'white',-width=>'8',-relief=>'ridge', -font=>'{Arial} 10 {bold}',-command => sub{do_clear()})->place(-x=>120,-y=>322);
$main->Button(-text => '关 于',-activebackground=>'white',-width=>'8',-relief=>'ridge', -font=>'{Arial} 10 {bold}',-command => sub{do_about()})->place(-x=>230,-y=>322);
my $status = $main->Label(-text=>"谢谢你使用 Perl SendMail 1.0 ...", -font=>'{System} 9 {normal}',-relief=>'sunken', -borderwidth=>2, -anchor=>"w",-width=>45);
$status->place(-x=>0,-y=>360);

MainLoop;

sub do_send {
# Fill in status area.
my ($host,$user,$pass,$from,$to,$subject,$body) = @_;
my $host1 = $host->get;
my $user1 = $user->get;
my $pass1 = $pass->get;
my $from1 = $from->get;
my $to1   = $to->get;
my $subject1= $subject->get;
my $body1 = $body->get('0.0','end');

if ($host1 eq ""){
&MsgShow('OK','error',"请输入SMTP服务器！","error");
}
elsif ($user1 eq ""){
&MsgShow('OK','error',"请输入用户名！","error");
}
elsif ($pass1 eq ""){
&MsgShow('OK','error',"请输入密码！","error");
}
elsif ($from1 !~ /@/ or $from1 eq ""){
&MsgShow('OK','error',"发信人的信箱 $from1 格式错误，请重新输入！","error");
}
elsif ($to1 !~ /@/ or $to1 eq ""){
&MsgShow('OK','error',"收信人的信箱 $to1 格式错误，请重新输入！","error");
}else{
&sendmail($host1,$user1,$pass1,$from1,$to1,$subject1,$body1)
or die &MsgShow('OK','失败',"信件发送失败","error");
&MsgShow('OK','完成',"给$to1的信件发送成功！","info");
$status->configure(-text=>"给$to1的信件发送成功！");
}
}
sub do_clear {
$host->delete('0.0','end');
$user->delete('0.0','end');
$pass->delete('0.0','end');
$from->delete('0.0','end');
$to->delete('0.0','end');
$subject->delete('0.0','end');
$body->delete('0.0','end');
$status->configure(-text=>"清空完成，请重新输入......");
&MsgShow('OK','Clear',"清空完成，请重新输入......","info");
}

sub MsgShow
{
my ($type,$title,$msg,$ico)=@_;
my $msgbox = $main->messageBox(-type=>$type , -title => $title,-message => $msg,-icon => $ico);
return($msgbox);
}

sub Base64encode #Base64编码函数
{
my $res = "";
while ($_[0] =~ /(.{1,45})/gs)
{
$res .= substr(pack('u', $1), 1);
chop($res);
}
$res =~ tr| -_|A-Za-z0-9+/|;
my $padding = (3 - length($_[0]) % 3) % 3;
$res =~ s/.{$padding}$/'=' x $padding/e if ($padding);
return $res;
}

sub sendmail {
my ($host1,$user1,$pass1,$from1,$to1,$subject1,$body1) = @_;
my $SMTPPORT ||=25;
my ($a, $i, $name, $aliases, $proto, $type, $len, $thisaddr, $thataddr);
my @to = split(/,/, $host1);
my $AF_INET = 2;
my $SOCK_STREAM = 1;
my $SOCKADDR = 'S n a4 x8';
($name, $aliases, $proto) = getprotobyname('tcp');
($name, $aliases, $SMTPPORT) = getservbyname($SMTPPORT, 'tcp') unless ($SMTPPORT =~ /^/d+$/);
($name, $aliases, $type, $len, $thataddr) = gethostbyname($host1);
my $this = pack($SOCKADDR, $AF_INET, 0, $thisaddr);
my $that = pack($SOCKADDR, $AF_INET, $SMTPPORT, $thataddr);
return 0 unless (socket(S, $AF_INET, $SOCK_STREAM, $proto));
return 0 unless (bind(S, $this));
return 0 unless (connect(S, $that));
select(S);
$| = 1;
select(STDOUT);
$a = <S>;
if ($a !~ /^2/)
{
close(S);
undef $|;
return 0;
}
print S "EHLO localhost/n";
$a = <S>;
print S "AUTH LOGIN/n";
$a = <S>;
my $smtpuser = Base64encode($user1);
print S "$smtpuser/n";
$a = <S>;
my $smtppass = Base64encode($pass1);
print S "$smtppass/n";
$a = <S>;
if ($a !~ /^2/){
&MsgShow('OK','error',"ESMTP验证错误，请检查用户名和密码！","error");
close(S);
return 0;
}
print S "MAIL FROM: $from1/n";
$a = <S>;
if ($a !~ /^2/)
{
close(S);
return 0;
}
print S "RCPT TO: <$to1>/n";
$a = <S>;
if ($a !~ /^2/)
{
close(S);
return 0;
}
print S "DATA/n";
print S "From: $user1<$from1>/n";
print S "Subject: $subject1/n";
print S $body1;
print S "/n/n";
print S "./n";
$a = <S>;
print S "QUIT/n";
$a = <S>;
close(S);
return 1;
}

sub do_about {
require Tk::LabFrame;
$status->configure(-text=>"关于 Perl SendMail 1.0 ....");
my $about = $main->Toplevel;
$about->title('关于....');
$about->geometry("300x280");
$about->Photo('main_bg', -file => "$mainbg");
$about->Label(-image => 'main_bg')->pack(-side=>'left',-anchor=>'nw');
$about->LabFrame(-label => "About...",-labelside => 'acrosstop',width=>270,height=>100)->place(-x=>10,-y=>105);
$about->Label(-text => "        Perl SendMail 原是以前写的一段发邮件的 /n 代码，这几天学习 Perl/Tk 顺便给她做了个图形/n 界面。如果有什么疏漏之处还请朋友们 Mail 我,/n  谢谢你们的支持！                                                   ",
-font => '{Arial} 9 {normal}'
)->place(-x=>20,-y=>125);
$about->Label(-text => "- jondy",-font => '{Comic Sans MS} 10 {normal}')->place(-x=>218,-y=>199);
$about->Label(-text => "Http://jondy.2best.cc /n Mail:h4ck/@163.com",-font => '{Arial} 9 {normal}')->place(-x=>20,-y=>190);
$about->Button(-text => 'OK',-width=>'10',-relief=>'ridge', -font=>'{Arial} 10 {normal}',-command => sub{$about->destroy})->place(-x=>200,-y=>242);
}