#! c: /perl/bin/perl.exe
# Jondy
# Http://blog.9cbs.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 is not found, please reinstall!", "error") (} $ 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 => 'server:', - 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 => 'username:', - 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 => "password: ' , -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 =>' sender: ', - 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 => "Received: ', - 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 => 'topic:', - 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 => 'Send', -Width => '8', - Relief => 'Ridge', -font => '{arial} 10 {bold}', - command => Sub {DO_SEND ($ HOST, $ User, $ Pass, $ from, $ j, $ subject, $ body)} , -activebackground => 'White') -> Place (-x => 10, -y => 322); $ main-> button (-Text => "
Clear ', -activebackground =>' White ', - width =>' 8 ', - Relief =>' Ridge ', -font =>' {arial} 10 {bold} ', - command => sub {DO_CLEAR () } -> places (-x => 120, -y => 322); $ main-> button (-text => 'About', -activebackground => 'White', - width => '8', - Relief => 'Ridge', -font => '{arial} 10 {bold}', - command => sub {DO_ABOUT ()}) -> Place (-x => 230, -y => 322); MY $ status = $ main-> label (-text => "Thank you for using 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, $ @@ 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 '," Please enter the SMTP server! "," Error ");} Elsif ($ USER1 EQ") {& msgshow (' OK ',' Error ', "Please enter your username!", "Error");} Elsif ($ Pass1 EQ ") {& msgshow (' ok ',' error '," Please enter your password! "," error ") } Elsif ($ from1! ~ / @ / or $ from1 EQ "" ") {& Msgshow ('ok', 'error'," sender's mailbox $ from1 format error, please re-enter! "," error ");} Elsif ($ TO1! ~ / @ / or $ to1 EQ") {& msgshow ('ok', 'error', "
Received mailbox $ TO1 format error, please re-enter! "Error");} else {& sendmail ($ Host1, $ USER1, $ Pass1, $ from1, $ TO1, $ SUBJECT1, $ BODY1) OR DIE & MSGSHOW ('OK', 'Failed "," Letter Send Failure " "Error"); & msgshow ('OK', 'Completed', "Successful to $ TO1"! "," info "); $ status-> configure (-text =>" to send a letter to $ 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 => "Clear completion, please re-enter ..."); & msgshow ('ok', 'clear', "Clearing, please re-enter ...", "info");} Sub msgshow {MY ($ TYPE, $ TITLE, $ MSG, $ ICO) = @ _; my $ msgbox = $ main-> Messagebox (-Type => $ TIPE, -TISSAGE => $ msg, -ICON => $ ICO); Return ($ msgbox);} Sub Base64Encode # base64 encoding function {MY $ RES = " "; WHILE ($ _ [0 ]/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, $ TYPE, $ LEN, $ THISADDR, $ THATDR); MY @To = Split (/, /, $ host1); My $ ap_inet = 2; My $ SOCK_STREAM = 1; MY $ SOCKADDR = 'S N A4 X8'; $ Name, $ AliaS, $ Proto) =
GetProtobyname ('TCP'); ($ Name, $ AliaS, $ SMTPPORT) = GetServbyName ($ SMTPPORT, 'TCP') Unless ($ SMTPPORT = ~ / ^ / D $ /); ($ Name, $ AliaS, $ TYPE $ LEN, $ THATDR) = gethostbyname ($ Host1); My $ this = Pack ($ SOCKADDR, $ AF_INET, 0, $ THISADDR); My $ THATDD ($ SOCKADDR, $ AF_INET, $ SMTPPORT, $ THATDR) Return 0 Unless (Socket (S, $ proto)); Return 0 Unless (Bind (S, $ this)); Return 0 Unless (Connect (S, $ That); SELECT (S) ; $ | = 1; select (stdout); $ a = ; if ($ a! ~ / ^ 2 /) {close (s); undef $ |; return 0;} print s "ehlo localhost / n "; $ a = ; print s" auth login / n "; $ a = ; my $ smtpuser = base64encode ($ user1); Print S" $ SMTPUSER / N "; $ a = MY $ SMTPASS = BASE64ENCODE ($ Pass1); Print S "$ SMTPASS / N"; $ A = ; if ($ A! ~ / ^ 2 /) {& msgshow ('OK', 'Error', " ESMTP verification error, please check the username and password! "," Error "); Close (s); return 0;} Print S" Mail from: $ from1 / n "; $ a = ; if ($ A! ~ / ^ 2 /) {Close (s); return 0;} Print S "RCPT TO: <$ TO1> / N"; $ a = ; if ($ A! ~ / ^ 2 /) {Close (S); return 0;} print s "DA TA / N "; Print S" from: $ USER1 <$ from1> / n "; Print S" Subject: $ Subject1 / N "; Print S $ Body1; Print S" / N / N "; Print S" ./ N "; $ a = ; Print S" quit / n "; $ a = ; close (s); return 1;} Sub do_about {Require TK :: LabFrame; $ status-> configure (- Text => "About Perl Sendmail 1.0 ...."); MY $ About = $ main-> topLevel; $ About-> Title ('About ....'); $ About-> Geometry ("300x280") ; $ about-> photo ('main_bg', -file =
