home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d3456 / SYNAPSE.ZIP / source / lib / POP3send.pas < prev    next >
Pascal/Delphi Source File  |  2002-07-07  |  11KB  |  346 lines
  1. {==============================================================================|
  2. | Project : Delphree - Synapse                                   | 002.001.000 |
  3. |==============================================================================|
  4. | Content: POP3 client                                                         |
  5. |==============================================================================|
  6. | Copyright (c)1999-2002, Lukas Gebauer                                        |
  7. | All rights reserved.                                                         |
  8. |                                                                              |
  9. | Redistribution and use in source and binary forms, with or without           |
  10. | modification, are permitted provided that the following conditions are met:  |
  11. |                                                                              |
  12. | Redistributions of source code must retain the above copyright notice, this  |
  13. | list of conditions and the following disclaimer.                             |
  14. |                                                                              |
  15. | Redistributions in binary form must reproduce the above copyright notice,    |
  16. | this list of conditions and the following disclaimer in the documentation    |
  17. | and/or other materials provided with the distribution.                       |
  18. |                                                                              |
  19. | Neither the name of Lukas Gebauer nor the names of its contributors may      |
  20. | be used to endorse or promote products derived from this software without    |
  21. | specific prior written permission.                                           |
  22. |                                                                              |
  23. | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
  24. | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
  25. | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
  26. | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
  27. | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
  28. | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
  29. | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
  30. | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
  31. | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
  32. | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
  33. | DAMAGE.                                                                      |
  34. |==============================================================================|
  35. | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  36. | Portions created by Lukas Gebauer are Copyright (c)2001-2002.                |
  37. | All Rights Reserved.                                                         |
  38. |==============================================================================|
  39. | Contributor(s):                                                              |
  40. |==============================================================================|
  41. | History: see HISTORY.HTM from distribution package                           |
  42. |          (Found at URL: http://www.ararat.cz/synapse/)                       |
  43. |==============================================================================}
  44.  
  45. {$WEAKPACKAGEUNIT ON}
  46.  
  47. //RFC-1734
  48. //RFC-1939
  49. //RFC-2195
  50. //RFC-2449
  51. //RFC-2595
  52.  
  53. unit POP3send;
  54.  
  55. interface
  56.  
  57. uses
  58.   SysUtils, Classes,
  59.   blcksock, SynaUtil, SynaCode;
  60.  
  61. const
  62.   cPop3Protocol = 'pop3';
  63.  
  64. type
  65.   TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
  66.  
  67.   TPOP3Send = class(TSynaClient)
  68.   private
  69.     FSock: TTCPBlockSocket;
  70.     FResultCode: Integer;
  71.     FResultString: string;
  72.     FFullResult: TStringList;
  73.     FUsername: string;
  74.     FPassword: string;
  75.     FStatCount: Integer;
  76.     FStatSize: Integer;
  77.     FTimeStamp: string;
  78.     FAuthType: TPOP3AuthType;
  79.     FPOP3cap: TStringList;
  80.     FAutoTLS: Boolean;
  81.     FFullSSL: Boolean;
  82.     function ReadResult(Full: Boolean): Integer;
  83.     function Connect: Boolean;
  84.     function AuthLogin: Boolean;
  85.     function AuthApop: Boolean;
  86.   public
  87.     constructor Create;
  88.     destructor Destroy; override;
  89.     function Capability: Boolean;
  90.     function Login: Boolean;
  91.     procedure Logout;
  92.     function Reset: Boolean;
  93.     function NoOp: Boolean;
  94.     function Stat: Boolean;
  95.     function List(Value: Integer): Boolean;
  96.     function Retr(Value: Integer): Boolean;
  97.     function Dele(Value: Integer): Boolean;
  98.     function Top(Value, Maxlines: Integer): Boolean;
  99.     function Uidl(Value: Integer): Boolean;
  100.     function StartTLS: Boolean;
  101.     function FindCap(const Value: string): string;
  102.   published
  103.     property ResultCode: Integer read FResultCode;
  104.     property ResultString: string read FResultString;
  105.     property FullResult: TStringList read FFullResult;
  106.     property Username: string read FUsername Write FUsername;
  107.     property Password: string read FPassword Write FPassword;
  108.     property StatCount: Integer read FStatCount;
  109.     property StatSize: Integer read  FStatSize;
  110.     property TimeStamp: string read FTimeStamp;
  111.     property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
  112.     property Sock: TTCPBlockSocket read FSock;
  113.     property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
  114.     property FullSSL: Boolean read FFullSSL Write FFullSSL;
  115.   end;
  116.  
  117. implementation
  118.  
  119. const
  120.   CRLF = #13#10;
  121.  
  122. constructor TPOP3Send.Create;
  123. begin
  124.   inherited Create;
  125.   FFullResult := TStringList.Create;
  126.   FPOP3cap := TStringList.Create;
  127.   FSock := TTCPBlockSocket.Create;
  128.   FSock.CreateSocket;
  129.   FSock.ConvertLineEnd := True;
  130.   FTimeout := 300000;
  131.   FTargetPort := cPop3Protocol;
  132.   FUsername := '';
  133.   FPassword := '';
  134.   FStatCount := 0;
  135.   FStatSize := 0;
  136.   FAuthType := POP3AuthAll;
  137.   FAutoTLS := False;
  138.   FFullSSL := False;
  139. end;
  140.  
  141. destructor TPOP3Send.Destroy;
  142. begin
  143.   FSock.Free;
  144.   FPOP3cap.Free;
  145.   FullResult.Free;
  146.   inherited Destroy;
  147. end;
  148.  
  149. function TPOP3Send.ReadResult(Full: Boolean): Integer;
  150. var
  151.   s: string;
  152. begin
  153.   Result := 0;
  154.   FFullResult.Clear;
  155.   s := FSock.RecvString(FTimeout);
  156.   if Pos('+OK', s) = 1 then
  157.     Result := 1;
  158.   FResultString := s;
  159.   if Full and (Result = 1) then
  160.     repeat
  161.       s := FSock.RecvString(FTimeout);
  162.       if s = '.' then
  163.         Break;
  164.       FFullResult.Add(s);
  165.     until FSock.LastError <> 0;
  166.   FResultCode := Result;
  167. end;
  168.  
  169. function TPOP3Send.AuthLogin: Boolean;
  170. begin
  171.   Result := False;
  172.   FSock.SendString('USER ' + FUserName + CRLF);
  173.   if ReadResult(False) <> 1 then
  174.     Exit;
  175.   FSock.SendString('PASS ' + FPassword + CRLF);
  176.   Result := ReadResult(False) = 1;
  177. end;
  178.  
  179. function TPOP3Send.AuthAPOP: Boolean;
  180. var
  181.   s: string;
  182. begin
  183.   s := StrToHex(MD5(FTimeStamp + FPassWord));
  184.   FSock.SendString('APOP ' + FUserName + ' ' + s + CRLF);
  185.   Result := ReadResult(False) = 1;
  186. end;
  187.  
  188. function TPOP3Send.Connect: Boolean;
  189. begin
  190.   // Do not call this function! It is calling by LOGIN method!
  191.   FStatCount := 0;
  192.   FStatSize := 0;
  193.   FSock.CloseSocket;
  194.   FSock.LineBuffer := '';
  195.   FSock.CreateSocket;
  196.   if FFullSSL then
  197.     FSock.SSLEnabled := True;
  198.   FSock.Bind(FIPInterface, cAnyPort);
  199.   FSock.Connect(FTargetHost, FTargetPort);
  200.   Result := FSock.LastError = 0;
  201. end;
  202.  
  203. function TPOP3Send.Capability: Boolean;
  204. begin
  205.   FPOP3cap.Clear;
  206.   Result := False;
  207.   FSock.SendString('CAPA' + CRLF);
  208.   Result := ReadResult(True) = 1;
  209.   if Result then
  210.     FPOP3cap.AddStrings(FFullResult);
  211. end;
  212.  
  213. function TPOP3Send.Login: Boolean;
  214. var
  215.   s, s1: string;
  216. begin
  217.   Result := False;
  218.   FTimeStamp := '';
  219.   if not Connect then
  220.     Exit;
  221.   if ReadResult(False) <> 1 then
  222.     Exit;
  223.   s := SeparateRight(FResultString, '<');
  224.   if s <> FResultString then
  225.   begin
  226.     s1 := SeparateLeft(s, '>');
  227.     if s1 <> s then
  228.       FTimeStamp := '<' + s1 + '>';
  229.   end;
  230.   Result := False;
  231.   if Capability then
  232.     if FAutoTLS and (Findcap('STLS') <> '') then
  233.       if StartTLS then
  234.         Capability;
  235.   if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
  236.   begin
  237.     Result := AuthApop;
  238.     if not Result then
  239.     begin
  240.       if not Connect then
  241.         Exit;
  242.       if ReadResult(False) <> 1 then
  243.         Exit;
  244.     end;
  245.   end;
  246.   if not Result and not (FAuthType = POP3AuthAPOP) then
  247.     Result := AuthLogin;
  248. end;
  249.  
  250. procedure TPOP3Send.Logout;
  251. begin
  252.   FSock.SendString('QUIT' + CRLF);
  253.   ReadResult(False);
  254.   FSock.CloseSocket;
  255. end;
  256.  
  257. function TPOP3Send.Reset: Boolean;
  258. begin
  259.   FSock.SendString('RSET' + CRLF);
  260.   Result := ReadResult(False) = 1;
  261. end;
  262.  
  263. function TPOP3Send.NoOp: Boolean;
  264. begin
  265.   FSock.SendString('NOOP' + CRLF);
  266.   Result := ReadResult(False) = 1;
  267. end;
  268.  
  269. function TPOP3Send.Stat: Boolean;
  270. var
  271.   s: string;
  272. begin
  273.   Result := False;
  274.   FSock.SendString('STAT' + CRLF);
  275.   if ReadResult(False) <> 1 then
  276.     Exit;
  277.   s := SeparateRight(ResultString, '+OK ');
  278.   FStatCount := StrToIntDef(SeparateLeft(s, ' '), 0);
  279.   FStatSize := StrToIntDef(SeparateRight(s, ' '), 0);
  280.   Result := True;
  281. end;
  282.  
  283. function TPOP3Send.List(Value: Integer): Boolean;
  284. begin
  285.   if Value = 0 then
  286.     FSock.SendString('LIST' + CRLF)
  287.   else
  288.     FSock.SendString('LIST ' + IntToStr(Value) + CRLF);
  289.   Result := ReadResult(Value = 0) = 1;
  290. end;
  291.  
  292. function TPOP3Send.Retr(Value: Integer): Boolean;
  293. begin
  294.   FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
  295.   Result := ReadResult(True) = 1;
  296. end;
  297.  
  298. function TPOP3Send.Dele(Value: Integer): Boolean;
  299. begin
  300.   FSock.SendString('DELE ' + IntToStr(Value) + CRLF);
  301.   Result := ReadResult(False) = 1;
  302. end;
  303.  
  304. function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
  305. begin
  306.   FSock.SendString('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines) + CRLF);
  307.   Result := ReadResult(True) = 1;
  308. end;
  309.  
  310. function TPOP3Send.Uidl(Value: Integer): Boolean;
  311. begin
  312.   if Value = 0 then
  313.     FSock.SendString('UIDL' + CRLF)
  314.   else
  315.     FSock.SendString('UIDL ' + IntToStr(Value) + CRLF);
  316.   Result := ReadResult(Value = 0) = 1;
  317. end;
  318.  
  319. function TPOP3Send.StartTLS: Boolean;
  320. begin
  321.   Result := False;
  322.   FSock.SendString('STLS' + CRLF);
  323.   if ReadResult(False) = 1 then
  324.   begin
  325.     Fsock.SSLDoConnect;
  326.     Result := FSock.LastError = 0;
  327.   end;
  328. end;
  329.  
  330. function TPOP3Send.FindCap(const Value: string): string;
  331. var
  332.   n: Integer;
  333.   s: string;
  334. begin
  335.   s := UpperCase(Value);
  336.   Result := '';
  337.   for n := 0 to FPOP3cap.Count - 1 do
  338.     if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
  339.     begin
  340.       Result := FPOP3cap[n];
  341.       Break;
  342.     end;
  343. end;
  344.  
  345. end.
  346.