1{ lNet SMTP unit 2 3 CopyRight (C) 2005-2008 Ales Katona 4 5 This library is Free software; you can rediStribute it and/or modify it 6 under the terms of the GNU Library General Public License as published by 7 the Free Software Foundation; either version 2 of the License, or (at your 8 option) any later version. 9 10 This program is diStributed in the hope that it will be useful, but WITHOUT 11 ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or 12 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License 13 for more details. 14 15 You should have received a Copy of the GNU Library General Public License 16 along with This library; if not, Write to the Free Software Foundation, 17 Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 19 This license has been modified. See File LICENSE.ADDON for more inFormation. 20 Should you find these sources without a LICENSE File, please contact 21 me at ales@chello.sk 22} 23 24unit lsmtp; 25 26{$mode objfpc}{$H+} 27{$inline on} 28 29interface 30 31uses 32 Classes, SysUtils, Contnrs, Base64, 33 lNet, lEvents, lCommon, lMimeWrapper, lMimeStreams; 34 35type 36 TLSMTP = class; 37 TLSMTPClient = class; 38 39 TLSMTPStatus = (ssNone, ssCon, ssHelo, ssEhlo, ssAuthLogin, ssAuthPlain, 40 ssStartTLS, ssMail, ssRcpt, ssData, ssRset, ssQuit, ssLast); 41 42 TLSMTPStatusSet = set of TLSMTPStatus; 43 44 TLSMTPStatusRec = record 45 Status: TLSMTPStatus; 46 Args: array[1..2] of string; 47 end; 48 49 { TLSMTPStatusFront } 50 {$DEFINE __front_type__ := TLSMTPStatusRec} 51 {$i lcontainersh.inc} 52 TLSMTPStatusFront = TLFront; 53 54 TLSMTPClientStatusEvent = procedure (aSocket: TLSocket; 55 const aStatus: TLSMTPStatus) of object; 56 57 { TMail } 58 59 TMail = class 60 protected 61 FMailText: string; 62 FMailStream: TMimeStream; 63 FRecipients: string; 64 FSender: string; 65 FSubject: string; 66 function GetCount: Integer; 67 function GetSection(i: Integer): TMimeSection; 68 procedure SetSection(i: Integer; const AValue: TMimeSection); 69 public 70 constructor Create; 71 destructor Destroy; override; 72 procedure AddTextSection(const aText: string; const aCharSet: string = 'UTF-8'); 73 procedure AddFileSection(const aFileName: string); 74 procedure AddStreamSection(aStream: TStream; const FreeStream: Boolean = False); 75 procedure DeleteSection(const i: Integer); 76 procedure RemoveSection(aSection: TMimeSection); 77 procedure Reset; 78 public 79 property MailText: string read FMailText write FMailText; deprecated; // use sections! 80 property Sender: string read FSender write FSender; 81 property Recipients: string read FRecipients write FRecipients; 82 property Subject: string read FSubject write FSubject; 83 property Sections[i: Integer]: TMimeSection read GetSection write SetSection; default; 84 property SectionCount: Integer read GetCount; 85 end; 86 87 TLSMTP = class(TLComponent) 88 protected 89 FConnection: TLTcp; 90 FFeatureList: TStringList; 91 protected 92 function GetTimeout: Integer; 93 procedure SetTimeout(const AValue: Integer); 94 95 function GetSession: TLSession; 96 procedure SetSession(const AValue: TLSession); 97 procedure SetCreator(AValue: TLComponent); override; 98 99 function GetConnected: Boolean; 100 101 function GetSocketClass: TLSocketClass; 102 procedure SetSocketClass(const AValue: TLSocketClass); 103 104 function GetEventer: TLEventer; 105 procedure SetEventer(Value: TLEventer); 106 public 107 constructor Create(aOwner: TComponent); override; 108 destructor Destroy; override; 109 110 function HasFeature(aFeature: string): Boolean; 111 public 112 property Connected: Boolean read GetConnected; 113 property Connection: TLTcp read FConnection; 114 115 property SocketClass: TLSocketClass read GetSocketClass write SetSocketClass; 116 property Eventer: TLEventer read GetEventer write SetEventer; 117 property Timeout: Integer read GetTimeout write SetTimeout; 118 property Session: TLSession read GetSession write SetSession; 119 property FeatureList: TStringList read FFeatureList; 120 end; 121 122 { TLSMTPClient } 123 124 TLSMTPClient = class(TLSMTP, ILClient) 125 protected 126 FStatus: TLSMTPStatusFront; 127 FCommandFront: TLSMTPStatusFront; 128 FPipeLine: Boolean; 129 FAuthStep: Integer; 130 131 FOnConnect: TLSocketEvent; 132 FOnReceive: TLSocketEvent; 133 FOnDisconnect: TLSocketEvent; 134 FOnSuccess: TLSMTPClientStatusEvent; 135 FOnFailure: TLSMTPClientStatusEvent; 136 FOnError: TLSocketErrorEvent; 137 FOnSent: TLSocketProgressEvent; 138 139 FSL: TStringList; 140 FStatusSet: TLSMTPStatusSet; 141 FBuffer: string; 142 FDataBuffer: string; // intermediate wait buffer on DATA command 143 FTempBuffer: string; // used independently from FBuffer for feature list 144 FCharCount: Integer; // count of chars from last CRLF 145 FStream: TStream; 146 protected 147 procedure OnEr(const msg: string; aSocket: TLSocket); 148 procedure OnRe(aSocket: TLSocket); 149 procedure OnCo(aSocket: TLSocket); 150 procedure OnDs(aSocket: TLSocket); 151 procedure OnCs(aSocket: TLSocket); 152 protected 153 function CanContinue(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): Boolean; 154 155 function CleanInput(var s: string): Integer; 156 157 procedure EvaluateServer; 158 procedure EvaluateFeatures; 159 procedure EvaluateAnswer(const Ans: string); 160 procedure ExecuteFrontCommand; 161 162 procedure AddToBuffer(s: string); 163 procedure SendData(const FromStream: Boolean = False); 164 function EncodeBase64(const s: string): string; 165 public 166 constructor Create(aOwner: TComponent); override; 167 destructor Destroy; override; 168 169 function Connect(const aHost: string; const aPort: Word = 25): Boolean; virtual; overload; 170 function Connect: Boolean; virtual; overload; 171 172 function Get(var aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; 173 function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; virtual; 174 175 procedure SendMail(From, Recipients, Subject, Msg: string); 176 procedure SendMail(From, Recipients, Subject: string; aStream: TStream); 177 procedure SendMail(aMail: TMail); 178 179 procedure Helo(aHost: string = ''); 180 procedure Ehlo(aHost: string = ''); 181 procedure StartTLS; 182 procedure AuthLogin(aName, aPass: string); 183 procedure AuthPlain(aName, aPass: string); 184 procedure Mail(const From: string); 185 procedure Rcpt(const RcptTo: string); 186 procedure Data(const Msg: string); 187 procedure Rset; 188 procedure Quit; 189 190 procedure Disconnect(const Forced: Boolean = True); override; 191 192 procedure CallAction; override; 193 public 194 property PipeLine: Boolean read FPipeLine write FPipeLine; 195 property StatusSet: TLSMTPStatusSet read FStatusSet write FStatusSet; 196 property OnConnect: TLSocketEvent read FOnConnect write FOnConnect; 197 property OnReceive: TLSocketEvent read FOnReceive write FOnReceive; 198 property OnDisconnect: TLSocketEvent read FOnDisconnect write FOnDisconnect; 199 property OnSuccess: TLSMTPClientStatusEvent read FOnSuccess write FOnSuccess; 200 property OnFailure: TLSMTPClientStatusEvent read FOnFailure write FOnFailure; 201 property OnError: TLSocketErrorEvent read FOnError write FOnError; 202 property OnSent: TLSocketProgressEvent read FOnSent write FOnSent; 203 end; 204 205implementation 206 207const 208 EMPTY_REC: TLSMTPStatusRec = (Status: ssNone; Args: ('', '')); 209 210{$i lcontainers.inc} 211 212function StatusToStr(const aStatus: TLSMTPStatus): string; 213const 214 STATAR: array[ssNone..ssLast] of string = ('ssNone', 'ssCon', 'ssHelo', 'ssEhlo', 215 'ssStartTLS', 'ssAuthLogin', 'ssAuthPlain', 216 'ssMail', 'ssRcpt', 'ssData', 'ssRset', 'ssQuit', 'ssLast'); 217begin 218 Result := STATAR[aStatus]; 219end; 220 221function MakeStatusRec(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): TLSMTPStatusRec; 222begin 223 Result.Status := aStatus; 224 Result.Args[1] := Arg1; 225 Result.Args[2] := Arg2; 226end; 227 228{ TLSMTP } 229 230function TLSMTP.GetSession: TLSession; 231begin 232 Result := FConnection.Session; 233end; 234 235procedure TLSMTP.SetSession(const AValue: TLSession); 236begin 237 FConnection.Session := aValue; 238end; 239 240procedure TLSMTP.SetCreator(AValue: TLComponent); 241begin 242 inherited SetCreator(AValue); 243 244 FConnection.Creator := AValue; 245end; 246 247function TLSMTP.GetTimeout: Integer; 248begin 249 Result := FConnection.Timeout; 250end; 251 252procedure TLSMTP.SetTimeout(const AValue: Integer); 253begin 254 FConnection.Timeout := aValue; 255end; 256 257function TLSMTP.GetConnected: Boolean; 258begin 259 Result := FConnection.Connected; 260end; 261 262function TLSMTP.GetSocketClass: TLSocketClass; 263begin 264 Result := FConnection.SocketClass; 265end; 266 267procedure TLSMTP.SetSocketClass(const AValue: TLSocketClass); 268begin 269 FConnection.SocketClass := AValue; 270end; 271 272function TLSMTP.GetEventer: TLEventer; 273begin 274 Result := FConnection.Eventer; 275end; 276 277procedure TLSMTP.SetEventer(Value: TLEventer); 278begin 279 FConnection.Eventer := Value; 280end; 281 282constructor TLSMTP.Create(aOwner: TComponent); 283begin 284 inherited Create(aOwner); 285 286 FFeatureList := TStringList.Create; 287 FConnection := TLTcp.Create(nil); 288 FConnection.Creator := Self; 289 // TODO: rework to use the new TLSocketTCP 290 FConnection.SocketClass := TLSocket; 291end; 292 293destructor TLSMTP.Destroy; 294begin 295 FFeatureList.Free; 296 FConnection.Free; 297 298 inherited Destroy; 299end; 300 301function TLSMTP.HasFeature(aFeature: string): Boolean; 302var 303 tmp: TStringList; 304 i, j: Integer; 305 AllArgs: Boolean; 306begin 307 Result := False; 308 try 309 tmp := TStringList.Create; 310 aFeature := UpperCase(aFeature); 311 aFeature := StringReplace(aFeature, ' ', ',', [rfReplaceAll]); 312 tmp.CommaText := aFeature; 313 for i := 0 to FFeatureList.Count - 1 do begin 314 if Pos(tmp[0], FFeatureList[i]) = 1 then begin 315 if tmp.Count = 1 then // no arguments, feature found, just exit true 316 Exit(True) 317 else begin // check arguments 318 AllArgs := True; 319 for j := 1 to tmp.Count - 1 do 320 if Pos(tmp[j], FFeatureList[i]) <= 0 then begin // some argument not found 321 AllArgs := False; 322 Break; 323 end; 324 if AllArgs then 325 Exit(True); 326 end; 327 end; 328 end; 329 330 finally 331 tmp.Free; 332 end; 333end; 334 335{ TLSMTPClient } 336 337constructor TLSMTPClient.Create(aOwner: TComponent); 338begin 339 inherited Create(aOwner); 340 FPort := 25; 341 FStatusSet := [ssNone..ssLast]; // full set 342 FSL := TStringList.Create; 343// {$warning TODO: fix pipelining support when server does it} 344 FPipeLine := False; 345 346 FConnection.OnError := @OnEr; 347 FConnection.OnCanSend := @OnCs; 348 FConnection.OnReceive := @OnRe; 349 FConnection.OnConnect := @OnCo; 350 FConnection.OnDisconnect := @OnDs; 351 352 FStatus := TLSMTPStatusFront.Create(EMPTY_REC); 353 FCommandFront := TLSMTPStatusFront.Create(EMPTY_REC); 354end; 355 356destructor TLSMTPClient.Destroy; 357begin 358 if FConnection.Connected then 359 Quit; 360 FSL.Free; 361 FStatus.Free; 362 FCommandFront.Free; 363 364 inherited Destroy; 365end; 366 367procedure TLSMTPClient.OnEr(const msg: string; aSocket: TLSocket); 368begin 369 if Assigned(FOnFailure) then begin 370 while not FStatus.Empty do 371 FOnFailure(aSocket, FStatus.Remove.Status); 372 end else 373 FStatus.Clear; 374 375 if Assigned(FOnError) then 376 FOnError(msg, aSocket); 377end; 378 379procedure TLSMTPClient.OnRe(aSocket: TLSocket); 380begin 381 if Assigned(FOnReceive) then 382 FOnReceive(aSocket); 383end; 384 385procedure TLSMTPClient.OnCo(aSocket: TLSocket); 386begin 387 if Assigned(FOnConnect) then 388 FOnConnect(aSocket); 389end; 390 391procedure TLSMTPClient.OnDs(aSocket: TLSocket); 392begin 393 if Assigned(FOnDisconnect) then 394 FOnDisconnect(aSocket); 395end; 396 397procedure TLSMTPClient.OnCs(aSocket: TLSocket); 398begin 399 SendData(FStatus.First.Status = ssData); 400end; 401 402function TLSMTPClient.CanContinue(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): Boolean; 403begin 404 Result := FPipeLine or FStatus.Empty; 405 if not Result then 406 FCommandFront.Insert(MakeStatusRec(aStatus, Arg1, Arg2)); 407end; 408 409function TLSMTPClient.CleanInput(var s: string): Integer; 410var 411 i: Integer; 412begin 413 FSL.Text := s; 414 415 case FStatus.First.Status of // TODO: clear this to a proper place, the whole thing needs an overhaul 416 ssCon, 417 ssEhlo: FTempBuffer := FTempBuffer + UpperCase(s); 418 end; 419 420 if FSL.Count > 0 then 421 for i := 0 to FSL.Count - 1 do 422 if Length(FSL[i]) > 0 then EvaluateAnswer(FSL[i]); 423 s := StringReplace(s, CRLF, LineEnding, [rfReplaceAll]); 424 i := Pos('PASS', s); 425 if i > 0 then 426 s := Copy(s, 1, i-1) + 'PASS'; 427 Result := Length(s); 428end; 429 430procedure TLSMTPClient.EvaluateServer; 431begin 432 FFeatureList.Clear; 433 if Length(FTempBuffer) = 0 then 434 Exit; 435 436 if Pos('ESMTP', FTempBuffer) > 0 then 437 FFeatureList.Append('EHLO'); 438 FTempBuffer := ''; 439end; 440 441procedure TLSMTPClient.EvaluateFeatures; 442var 443 i: Integer; 444begin 445 FFeatureList.Clear; 446 if Length(FTempBuffer) = 0 then 447 Exit; 448 449 FFeatureList.Text := FTempBuffer; 450 FTempBuffer := ''; 451 FFeatureList.Delete(0); 452 453 i := 0; 454 while i < FFeatureList.Count do begin; 455 FFeatureList[i] := Copy(FFeatureList[i], 5, Length(FFeatureList[i])); // delete the response code crap 456 FFeatureList[i] := StringReplace(FFeatureList[i], '=', ' ', [rfReplaceAll]); 457 if FFeatureList.IndexOf(FFeatureList[i]) <> i then begin 458 FFeatureList.Delete(i); 459 Continue; 460 end; 461 Inc(i); 462 end; 463end; 464 465procedure TLSMTPClient.EvaluateAnswer(const Ans: string); 466 467 function GetNum: Integer; 468 begin 469 try 470 Result := StrToInt(Copy(Ans, 1, 3)); 471 except 472 Result := -1; 473 end; 474 end; 475 476 function ValidResponse(const Answer: string): Boolean; inline; 477 begin 478 Result := (Length(Ans) >= 3) and 479 (Ans[1] in ['1'..'5']) and 480 (Ans[2] in ['0'..'9']) and 481 (Ans[3] in ['0'..'9']); 482 483 if Result then 484 Result := (Length(Ans) = 3) or ((Length(Ans) > 3) and (Ans[4] = ' ')); 485 end; 486 487 procedure Eventize(const aStatus: TLSMTPStatus; const Res: Boolean); 488 begin 489 FStatus.Remove; 490 if Res then begin 491 if Assigned(FOnSuccess) and (aStatus in FStatusSet) then 492 FOnSuccess(FConnection.Iterator, aStatus); 493 end else begin 494 if Assigned(FOnFailure) and (aStatus in FStatusSet) then 495 FOnFailure(FConnection.Iterator, aStatus); 496 end; 497 end; 498 499var 500 x: Integer; 501begin 502 x := GetNum; 503 504 if ValidResponse(Ans) and not FStatus.Empty then 505 case FStatus.First.Status of 506 ssCon, 507 ssHelo, 508 ssEhlo: case x of 509 200..299: begin 510 case FStatus.First.Status of 511 ssCon : EvaluateServer; 512 ssEhlo : EvaluateFeatures; 513 end; 514 Eventize(FStatus.First.Status, True); 515 end; 516 else begin 517 Eventize(FStatus.First.Status, False); 518 Disconnect(False); 519 FFeatureList.Clear; 520 FTempBuffer := ''; 521 end; 522 end; 523 524 ssStartTLS: 525 case x of 526 200..299: begin 527 Eventize(FStatus.First.Status, True); 528 FConnection.Iterator.SetState(ssSSLActive); 529 end; 530 else begin 531 Eventize(FStatus.First.Status, False); 532 end; 533 end; 534 535 ssAuthLogin: 536 case x of 537 200..299: begin 538 Eventize(FStatus.First.Status, True); 539 end; 540 300..399: if FAuthStep = 0 then begin 541 AddToBuffer(FStatus.First.Args[1] + CRLF); 542 Inc(FAuthStep); 543 SendData; 544 end else if FAuthStep = 1 then begin 545 AddToBuffer(FStatus.First.Args[2] + CRLF); 546 Inc(FAuthStep); 547 SendData; 548 end else begin 549 Eventize(FStatus.First.Status, False); 550 end; 551 else begin 552 Eventize(FStatus.First.Status, False); 553 end; 554 end; 555 556 ssAuthPlain: 557 case x of 558 200..299: begin 559 Eventize(FStatus.First.Status, True); 560 end; 561 300..399: begin 562 AddToBuffer(FStatus.First.Args[1] + FStatus.First.Args[2] + CRLF); 563 SendData; 564 end; 565 else begin 566 Eventize(FStatus.First.Status, False); 567 end; 568 end; 569 570 ssMail, 571 ssRcpt: begin 572 Eventize(FStatus.First.Status, (x >= 200) and (x < 299)); 573 end; 574 575 ssData: case x of 576 200..299: begin 577 Eventize(FStatus.First.Status, True); 578 end; 579 300..399: begin 580 AddToBuffer(FDataBuffer); 581 FDataBuffer := ''; 582 SendData(True); 583 end; 584 else begin 585 FDataBuffer := ''; 586 Eventize(FStatus.First.Status, False); 587 end; 588 end; 589 590 ssRset: begin 591 Eventize(FStatus.First.Status, (x >= 200) and (x < 299)); 592 end; 593 594 ssQuit: begin 595 Eventize(FStatus.First.Status, (x >= 200) and (x < 299)); 596{ if Assigned(FOnDisconnect) then 597 FOnDisconnect(FConnection.Iterator);} 598 Disconnect(False); 599 end; 600 end; 601 602 if FStatus.Empty and not FCommandFront.Empty then 603 ExecuteFrontCommand; 604end; 605 606procedure TLSMTPClient.ExecuteFrontCommand; 607begin 608 with FCommandFront.First do 609 case Status of 610 ssHelo: Helo(Args[1]); 611 ssEhlo: Ehlo(Args[1]); 612 ssMail: Mail(Args[1]); 613 ssRcpt: Rcpt(Args[1]); 614 ssData: Data(Args[1]); 615 ssRset: Rset; 616 ssQuit: Quit; 617 end; 618 FCommandFront.Remove; 619end; 620 621procedure TLSMTPClient.AddToBuffer(s: string); 622var 623 i: Integer; 624 Skip: Boolean = False; 625begin 626 for i := 1 to Length(s) do begin 627 if Skip then begin 628 Skip := False; 629 Continue; 630 end; 631 632 if (s[i] = #13) or (s[i] = #10) then begin 633 if s[i] = #13 then 634 if (i < Length(s)) and (s[i + 1] = #10) then begin 635 FCharCount := 0; 636 Skip := True; // skip the crlf 637 end else begin // insert LF to a standalone CR 638 System.Insert(#10, s, i + 1); 639 FCharCount := 0; 640 Skip := True; // skip the new crlf 641 end; 642 643 if s[i] = #10 then begin 644 System.Insert(#13, s, i); 645 FCharCount := 0; 646 Skip := True; // skip the new crlf 647 end; 648 end else if FCharCount >= 1000 then begin // line too long 649 System.Insert(CRLF, s, i); 650 FCharCount := 0; 651 Skip := True; 652 end else 653 Inc(FCharCount); 654 end; 655 656 FBuffer := FBuffer + s; 657end; 658 659procedure TLSMTPClient.SendData(const FromStream: Boolean = False); 660const 661 SBUF_SIZE = 65535; 662 663 procedure FillBuffer; 664 var 665 s: string; 666 begin 667 SetLength(s, SBUF_SIZE - Length(FBuffer)); 668 SetLength(s, FStream.Read(s[1], Length(s))); 669 670 AddToBuffer(s); 671 672 if FStream.Position = FStream.Size then begin // we finished the stream 673 AddToBuffer(CRLF + '.' + CRLF); 674 FStream := nil; 675 end; 676 end; 677 678var 679 n: Integer; 680 Sent: Integer; 681begin 682 if FromStream and Assigned(FStream) then 683 FillBuffer; 684 685 n := 1; 686 Sent := 0; 687 while (Length(FBuffer) > 0) and (n > 0) do begin 688 n := FConnection.SendMessage(FBuffer); 689 Sent := Sent + n; 690 if n > 0 then 691 Delete(FBuffer, 1, n); 692 693 if FromStream and Assigned(FStream) and (Length(FBuffer) < SBUF_SIZE) then 694 FillBuffer; 695 end; 696 697 if Assigned(FOnSent) and (FStatus.First.Status = ssData) then 698 FOnSent(FConnection.Iterator, Sent); 699end; 700 701function TLSMTPClient.EncodeBase64(const s: string): string; 702var 703 Dummy: TBogusStream; 704 Enc: TBase64EncodingStream; 705begin 706 Result := ''; 707 if Length(s) = 0 then 708 Exit; 709 710 Dummy := TBogusStream.Create; 711 Enc := TBase64EncodingStream.Create(Dummy); 712 713 Enc.Write(s[1], Length(s)); 714 Enc.Free; 715 SetLength(Result, Dummy.Size); 716 Dummy.Read(Result[1], Dummy.Size); 717 718 Dummy.Free; 719end; 720 721function TLSMTPClient.Connect(const aHost: string; const aPort: Word = 25): Boolean; 722begin 723 Result := False; 724 Disconnect(True); 725 if FConnection.Connect(aHost, aPort) then begin 726 FTempBuffer := ''; 727 FHost := aHost; 728 FPort := aPort; 729 FStatus.Insert(MakeStatusRec(ssCon, '', '')); 730 Result := True; 731 end; 732end; 733 734function TLSMTPClient.Connect: Boolean; 735begin 736 Result := Connect(FHost, FPort); 737end; 738 739function TLSMTPClient.Get(var aData; const aSize: Integer; aSocket: TLSocket): Integer; 740var 741 s: string; 742begin 743 Result := FConnection.Get(aData, aSize, aSocket); 744 if Result > 0 then begin 745 SetLength(s, Result); 746 Move(aData, PChar(s)^, Result); 747 CleanInput(s); 748 end; 749end; 750 751function TLSMTPClient.GetMessage(out msg: string; aSocket: TLSocket): Integer; 752begin 753 Result := FConnection.GetMessage(msg, aSocket); 754 if Result > 0 then 755 Result := CleanInput(msg); 756end; 757 758procedure TLSMTPClient.SendMail(From, Recipients, Subject, Msg: string); 759var 760 i: Integer; 761begin 762 FStream := nil; 763 From := EncodeMimeHeaderText(From); 764 Recipients := EncodeMimeHeaderText(Recipients); 765 Subject := EncodeMimeHeaderText(Subject); 766 767 if (Length(Recipients) > 0) and (Length(From) > 0) then begin 768 Mail(From); 769 FSL.CommaText := StringReplace(Recipients, ' ', ',', [rfReplaceAll]); 770 for i := 0 to FSL.Count-1 do 771 Rcpt(FSL[i]); 772 Data('From: ' + From + CRLF + 'Subject: ' + Subject + CRLF + 'To: ' + FSL.CommaText + CRLF + CRLF + Msg); 773 end; 774end; 775 776procedure TLSMTPClient.SendMail(From, Recipients, Subject: string; aStream: TStream); 777var 778 i: Integer; 779begin 780 From := EncodeMimeHeaderText(From); 781 Recipients := EncodeMimeHeaderText(Recipients); 782 Subject := EncodeMimeHeaderText(Subject); 783 784 FStream := aStream; 785 786 if (Length(Recipients) > 0) and (Length(From) > 0) then begin 787 Mail(From); 788 FSL.CommaText := StringReplace(Recipients, ' ', ',', [rfReplaceAll]); 789 for i := 0 to FSL.Count-1 do 790 Rcpt(FSL[i]); 791 Data('From: ' + From + CRLF + 'Subject: ' + Subject + CRLF + 'To: ' + FSL.CommaText + CRLF); 792 end; 793end; 794 795procedure TLSMTPClient.SendMail(aMail: TMail); 796begin 797 if Length(aMail.FMailText) > 0 then 798 SendMail(aMail.Sender, aMail.Recipients, aMail.Subject, aMail.FMailText) 799 else if Assigned(aMail.FMailStream) then 800 SendMail(aMail.Sender, aMail.Recipients, aMail.Subject, aMail.FMailStream); 801end; 802 803procedure TLSMTPClient.Helo(aHost: string = ''); 804begin 805 if Length(aHost) = 0 then 806 aHost := FHost; 807 808 if CanContinue(ssHelo, aHost, '') then begin 809 AddToBuffer('HELO ' + aHost + CRLF); 810 FStatus.Insert(MakeStatusRec(ssHelo, '', '')); 811 SendData; 812 end; 813end; 814 815procedure TLSMTPClient.Ehlo(aHost: string = ''); 816begin 817 if Length(aHost) = 0 then 818 aHost := FHost; 819 if CanContinue(ssEhlo, aHost, '') then begin 820 FTempBuffer := ''; // for ehlo response 821 AddToBuffer('EHLO ' + aHost + CRLF); 822 FStatus.Insert(MakeStatusRec(ssEhlo, '', '')); 823 SendData; 824 end; 825end; 826 827procedure TLSMTPClient.StartTLS; 828begin 829 if CanContinue(ssStartTLS, '', '') then begin 830 AddToBuffer('STARTTLS' + CRLF); 831 FStatus.Insert(MakeStatusRec(ssStartTLS, '', '')); 832 SendData; 833 end; 834end; 835 836procedure TLSMTPClient.AuthLogin(aName, aPass: string); 837begin 838 aName := EncodeBase64(aName); 839 aPass := EncodeBase64(aPass); 840 FAuthStep := 0; // first, send username 841 842 if CanContinue(ssAuthLogin, aName, aPass) then begin 843 AddToBuffer('AUTH LOGIN' + CRLF); 844 FStatus.Insert(MakeStatusRec(ssAuthLogin, aName, aPass)); 845 SendData; 846 end; 847end; 848 849procedure TLSMTPClient.AuthPlain(aName, aPass: string); 850begin 851 aName := EncodeBase64(#0 + aName); 852 aPass := EncodeBase64(#0 + aPass); 853 FAuthStep := 0; 854 855 if CanContinue(ssAuthPlain, aName, aPass) then begin 856 AddToBuffer('AUTH PLAIN' + CRLF); 857 FStatus.Insert(MakeStatusRec(ssAuthPlain, aName, aPass)); 858 SendData; 859 end; 860end; 861 862procedure TLSMTPClient.Mail(const From: string); 863begin 864 if CanContinue(ssMail, From, '') then begin 865 AddToBuffer('MAIL FROM:' + '<' + From + '>' + CRLF); 866 FStatus.Insert(MakeStatusRec(ssMail, '', '')); 867 SendData; 868 end; 869end; 870 871procedure TLSMTPClient.Rcpt(const RcptTo: string); 872begin 873 if CanContinue(ssRcpt, RcptTo, '') then begin 874 AddToBuffer('RCPT TO:' + '<' + RcptTo + '>' + CRLF); 875 FStatus.Insert(MakeStatusRec(ssRcpt, '', '')); 876 SendData; 877 end; 878end; 879 880procedure TLSMTPClient.Data(const Msg: string); 881begin 882 if CanContinue(ssData, Msg, '') then begin 883 AddToBuffer('DATA ' + CRLF); 884 FDataBuffer := ''; 885 886 if Assigned(FStream) then begin 887 if Length(Msg) > 0 then 888 FDataBuffer := Msg; 889 end else 890 FDataBuffer := Msg + CRLF + '.' + CRLF; 891 892 FStatus.Insert(MakeStatusRec(ssData, '', '')); 893 SendData(False); 894 end; 895end; 896 897procedure TLSMTPClient.Rset; 898begin 899 if CanContinue(ssRset, '', '') then begin 900 AddToBuffer('RSET' + CRLF); 901 FStatus.Insert(MakeStatusRec(ssRset, '', '')); 902 SendData; 903 end; 904end; 905 906procedure TLSMTPClient.Quit; 907begin 908 if CanContinue(ssQuit, '', '') then begin 909 AddToBuffer('QUIT' + CRLF); 910 FStatus.Insert(MakeStatusRec(ssQuit, '', '')); 911 SendData; 912 end; 913end; 914 915procedure TLSMTPClient.Disconnect(const Forced: Boolean = True); 916begin 917 FConnection.Disconnect(Forced); 918 FStatus.Clear; 919 FCommandFront.Clear; 920end; 921 922procedure TLSMTPClient.CallAction; 923begin 924 FConnection.CallAction; 925end; 926 927{ TMail } 928 929function TMail.GetCount: Integer; 930begin 931 Result := FMailStream.Count; 932end; 933 934function TMail.GetSection(i: Integer): TMimeSection; 935begin 936 Result := FMailStream.Sections[i]; 937end; 938 939procedure TMail.SetSection(i: Integer; const AValue: TMimeSection); 940begin 941 FMailStream.Sections[i] := aValue; 942end; 943 944constructor TMail.Create; 945begin 946 FMailStream := TMimeStream.Create; 947end; 948 949destructor TMail.Destroy; 950begin 951 FMailStream.Free; 952end; 953 954procedure TMail.AddTextSection(const aText: string; const aCharSet: string); 955begin 956 FMailStream.AddTextSection(aText, aCharSet); 957end; 958 959procedure TMail.AddFileSection(const aFileName: string); 960begin 961 FMailStream.AddFileSection(aFileName); 962end; 963 964procedure TMail.AddStreamSection(aStream: TStream; const FreeStream: Boolean); 965begin 966 FMailStream.AddStreamSection(aStream, FreeStream); 967end; 968 969procedure TMail.DeleteSection(const i: Integer); 970begin 971 FMailStream.Delete(i); 972end; 973 974procedure TMail.RemoveSection(aSection: TMimeSection); 975begin 976 FMailStream.Remove(aSection); 977end; 978 979procedure TMail.Reset; 980begin 981 FMailStream.Reset; 982end; 983 984 985end. 986 987