pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@61 7c85be65-684b-0410-a082-b2ed4fbef004

Browse Source
This commit is contained in:
geby 2008-04-24 07:18:26 +00:00
parent c549c1c618
commit 288e3ae3c3
11 changed files with 840 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

201
blcksock.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 005.002.000 | | Project : Delphree - Synapse | 005.007.000 |
|==============================================================================| |==============================================================================|
| Content: Library base | | Content: Library base |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)1999,2000,2001. | | Portions created by Lukas Gebauer are Copyright (c)1999-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -90,6 +90,7 @@ type
FSocket: TSocket; FSocket: TSocket;
FProtocol: Integer; FProtocol: Integer;
procedure CreateSocket; virtual; procedure CreateSocket; virtual;
procedure AutoCreateSocket;
procedure SetSin(var Sin: TSockAddrIn; IP, Port: string); procedure SetSin(var Sin: TSockAddrIn; IP, Port: string);
function GetSinIP(Sin: TSockAddrIn): string; function GetSinIP(Sin: TSockAddrIn): string;
function GetSinPort(Sin: TSockAddrIn): Integer; function GetSinPort(Sin: TSockAddrIn): Integer;
@ -201,6 +202,11 @@ type
FSslBypass: Boolean; FSslBypass: Boolean;
FSsl: PSSL; FSsl: PSSL;
Fctx: PSSL_CTX; Fctx: PSSL_CTX;
FSSLPassword: string;
FSSLCiphers: string;
FSSLCertificateFile: string;
FSSLPrivateKeyFile: string;
FSSLCertCAFile: string;
FHTTPTunnelIP: string; FHTTPTunnelIP: string;
FHTTPTunnelPort: string; FHTTPTunnelPort: string;
FHTTPTunnel: Boolean; FHTTPTunnel: Boolean;
@ -209,6 +215,7 @@ type
FHTTPTunnelUser: string; FHTTPTunnelUser: string;
FHTTPTunnelPass: string; FHTTPTunnelPass: string;
procedure SetSslEnabled(Value: Boolean); procedure SetSslEnabled(Value: Boolean);
function SetSslKeys: boolean;
procedure SocksDoConnect(IP, Port: string); procedure SocksDoConnect(IP, Port: string);
procedure HTTPTunnelDoConnect(IP, Port: string); procedure HTTPTunnelDoConnect(IP, Port: string);
public public
@ -221,7 +228,7 @@ type
procedure Connect(IP, Port: string); override; procedure Connect(IP, Port: string); override;
procedure SSLDoConnect; procedure SSLDoConnect;
procedure SSLDoShutdown; procedure SSLDoShutdown;
function SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean; function SSLAcceptConnection: Boolean;
function GetLocalSinIP: string; override; function GetLocalSinIP: string; override;
function GetRemoteSinIP: string; override; function GetRemoteSinIP: string; override;
function GetLocalSinPort: Integer; override; function GetLocalSinPort: Integer; override;
@ -237,6 +244,11 @@ type
published published
property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled; property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled;
property SSLBypass: Boolean read FSslBypass write FSslBypass; property SSLBypass: Boolean read FSslBypass write FSslBypass;
property SSLPassword: string read FSSLPassword write FSSLPassword;
property SSLCiphers: string read FSSLCiphers write FSSLCiphers;
property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile;
property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile;
property SSLCertCAFile: string read FSSLCertCAFile write FSSLCertCAFile;
property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP;
property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort;
property HTTPTunnel: Boolean read FHTTPTunnel; property HTTPTunnel: Boolean read FHTTPTunnel;
@ -348,6 +360,8 @@ begin
end; end;
procedure TBlockSocket.SetSin(var Sin: TSockAddrIn; IP, Port: string); procedure TBlockSocket.SetSin(var Sin: TSockAddrIn; IP, Port: string);
type
pu_long = ^u_long;
var var
ProtoEnt: PProtoEnt; ProtoEnt: PProtoEnt;
ServEnt: PServEnt; ServEnt: PServEnt;
@ -373,10 +387,10 @@ begin
begin begin
HostEnt := synsock.GetHostByName(PChar(IP)); HostEnt := synsock.GetHostByName(PChar(IP));
if HostEnt <> nil then if HostEnt <> nil then
SIn.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^); SIn.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
end; end;
end; end;
DoStatus(HR_ResolvingEnd, IP+':'+Port); DoStatus(HR_ResolvingEnd, IP + ':' + Port);
end; end;
function TBlockSocket.GetSinIP(Sin: TSockAddrIn): string; function TBlockSocket.GetSinIP(Sin: TSockAddrIn): string;
@ -406,10 +420,17 @@ begin
DoStatus(HR_SocketCreate, ''); DoStatus(HR_SocketCreate, '');
end; end;
procedure TBlockSocket.AutoCreateSocket;
begin
if FSocket = INVALID_SOCKET then
CreateSocket;
end;
procedure TBlockSocket.CloseSocket; procedure TBlockSocket.CloseSocket;
begin begin
synsock.Shutdown(FSocket, 2); synsock.Shutdown(FSocket, 2);
synsock.CloseSocket(FSocket); synsock.CloseSocket(FSocket);
FSocket := INVALID_SOCKET;
DoStatus(HR_SocketClose, ''); DoStatus(HR_SocketClose, '');
end; end;
@ -418,6 +439,7 @@ var
Sin: TSockAddrIn; Sin: TSockAddrIn;
Len: Integer; Len: Integer;
begin begin
AutoCreateSocket;
SetSin(Sin, IP, Port); SetSin(Sin, IP, Port);
SockCheck(synsock.Bind(FSocket, Sin, SizeOf(Sin))); SockCheck(synsock.Bind(FSocket, Sin, SizeOf(Sin)));
Len := SizeOf(FLocalSin); Len := SizeOf(FLocalSin);
@ -431,6 +453,7 @@ procedure TBlockSocket.Connect(IP, Port: string);
var var
Sin: TSockAddrIn; Sin: TSockAddrIn;
begin begin
AutoCreateSocket;
SetSin(Sin, IP, Port); SetSin(Sin, IP, Port);
SockCheck(synsock.Connect(FSocket, Sin, SizeOf(Sin))); SockCheck(synsock.Connect(FSocket, Sin, SizeOf(Sin)));
GetSins; GetSins;
@ -452,13 +475,18 @@ end;
procedure TBlockSocket.LimitBandwidth(Length: Integer); procedure TBlockSocket.LimitBandwidth(Length: Integer);
var var
x: Cardinal; x: Cardinal;
y: integer;
begin begin
if FMaxBandwidth > 0 then if FMaxBandwidth > 0 then
begin begin
x := FNextSend - GetTick; y:= GetTick;
if x > 0 then if FNextSend > y then
Sleep(x); begin
FNextSend := GetTick + Trunc((FMaxBandwidth / 1000) * Length); x:= FNextSend - y;
if x > 0 then
sleep(x);
end;
FNextSend:= y + Trunc((Length / FMaxBandwidth) * 1000);
end; end;
end; end;
@ -557,7 +585,6 @@ end;
function TBlockSocket.RecvPacket(Timeout: Integer): string; function TBlockSocket.RecvPacket(Timeout: Integer): string;
var var
x: integer; x: integer;
s: string;
begin begin
Result := ''; Result := '';
FLastError := 0; FLastError := 0;
@ -573,9 +600,9 @@ begin
x := WaitingData; x := WaitingData;
if x > 0 then if x > 0 then
begin begin
SetLength(s, x); SetLength(Result, x);
x := RecvBuffer(Pointer(s), x); x := RecvBuffer(Pointer(Result), x);
Result := Copy(s, 1, x); SetLength(Result, x);
end; end;
end end
else else
@ -587,59 +614,63 @@ end;
function TBlockSocket.RecvByte(Timeout: Integer): Byte; function TBlockSocket.RecvByte(Timeout: Integer): Byte;
var
s: String;
begin begin
Result := 0; Result := 0;
if CanRead(Timeout) then FLastError := 0;
begin if FBuffer = '' then
SetLength(s, 1); FBuffer := RecvPacket(Timeout);
RecvBuffer(Pointer(s), 1); if (FBuffer = '') and (FLastError = 0) then
if s <> '' then
Result := Ord(s[1]);
end
else
FLastError := WSAETIMEDOUT; FLastError := WSAETIMEDOUT;
if FLastError = 0 then
begin
Result := Ord(FBuffer[1]);
System.Delete(FBuffer, 1, 1);
end;
ExceptCheck; ExceptCheck;
end; end;
function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: string): string; function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: string): string;
const
MaxSize = 1024;
var var
x: Integer; x: Integer;
s: string; s: string;
l: Integer; l: Integer;
begin begin
s := ''; FLastError := 0;
l := Length(Terminator);
Result := ''; Result := '';
l := system.Length(Terminator);
if l = 0 then if l = 0 then
Exit; Exit;
FLastError := 0; // if FBuffer contains requested data, return it...
repeat if FBuffer<>'' then
x := 0; begin
if FBuffer = '' then x := pos(Terminator, FBuffer);
begin
FBuffer := RecvPacket(Timeout);
if FLastError <> 0 then
Break;
end;
s := s + FBuffer;
FBuffer := '';
x := Pos(Terminator, s);
if x > 0 then if x > 0 then
begin begin
FBuffer := Copy(s, x + l, Length(s) - x - l + 1); Result := copy(FBuffer, 1, x - 1);
s := Copy(s, 1, x - 1); System.Delete(FBuffer, 1, x + l - 1);
exit;
end; end;
if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then end;
// now FBuffer is empty or not contains all data...
s := '';
x := 0;
repeat
s := s + RecvPacket(Timeout);
if FLastError <> 0 then
Break;
x := Pos(Terminator, s);
if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
begin begin
FLastError := WSAENOBUFS; FLastError := WSAENOBUFS;
Break; Break;
end; end;
until x > 0; until x > 0;
Result := s; if x > 0 then
begin
Result := Copy(s, 1, x - 1);
System.Delete(s, 1, x + l - 1);
end;
FBuffer := s;
ExceptCheck; ExceptCheck;
end; end;
@ -1341,6 +1372,7 @@ end;
procedure TUDPBlockSocket.Connect(IP, Port: string); procedure TUDPBlockSocket.Connect(IP, Port: string);
begin begin
AutoCreateSocket;
SetRemoteSin(IP, Port); SetRemoteSin(IP, Port);
FBuffer := ''; FBuffer := '';
DoStatus(HR_Connect, IP + ':' + Port); DoStatus(HR_Connect, IP + ':' + Port);
@ -1459,11 +1491,29 @@ end;
{======================================================================} {======================================================================}
function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
var
Password: String;
begin
Password := '';
if TTCPBlockSocket(userdata) is TTCPBlockSocket then
Password := TTCPBlockSocket(userdata).SSLPassword;
FillChar(buf, Size, 0);
if Length(Password) > (Size - 1) then
SetLength(Password, Size - 1);
StrPCopy(buf, Password);
Result := Length(Password);
end;
constructor TTCPBlockSocket.Create; constructor TTCPBlockSocket.Create;
begin begin
inherited Create; inherited Create;
FSslEnabled := False; FSslEnabled := False;
FSslBypass := False; FSslBypass := False;
FSSLCiphers := 'DEFAULT';
FSSLCertificateFile := '';
FSSLPrivateKeyFile := '';
FSSLPassword := '';
FSsl := nil; FSsl := nil;
Fctx := nil; Fctx := nil;
FHTTPTunnelIP := ''; FHTTPTunnelIP := '';
@ -1554,6 +1604,7 @@ end;
procedure TTCPBlockSocket.Connect(IP, Port: string); procedure TTCPBlockSocket.Connect(IP, Port: string);
begin begin
AutoCreateSocket;
if FSocksIP <> '' then if FSocksIP <> '' then
SocksDoConnect(IP, Port) SocksDoConnect(IP, Port)
else else
@ -1570,41 +1621,47 @@ var
b: Boolean; b: Boolean;
begin begin
inherited Connect(FSocksIP, FSocksPort); inherited Connect(FSocksIP, FSocksPort);
b := SocksOpen; if FLastError = 0 then
if b then begin
b := SocksRequest(1, IP, Port); b := SocksOpen;
if b then if b then
b := SocksResponse; b := SocksRequest(1, IP, Port);
if not b and (FLastError = 0) then if b then
FLastError := WSASYSNOTREADY; b := SocksResponse;
FSocksLocalIP := FSocksResponseIP; if not b and (FLastError = 0) then
FSocksLocalPort := FSocksResponsePort; FLastError := WSASYSNOTREADY;
FSocksRemoteIP := IP; FSocksLocalIP := FSocksResponseIP;
FSocksRemotePort := Port; FSocksLocalPort := FSocksResponsePort;
FSocksRemoteIP := IP;
FSocksRemotePort := Port;
end;
ExceptCheck; ExceptCheck;
DoStatus(HR_Connect, IP + ':' + Port); DoStatus(HR_Connect, IP + ':' + Port);
end; end;
procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string); procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string);
//bugfixed by Mike Green (mgreen@emixode.com)
var var
s: string; s: string;
begin begin
try try
FBypassFlag := True; FBypassFlag := True;
inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort);
if FLastError <> 0 then
Exit;
FHTTPTunnel := False; FHTTPTunnel := False;
SendString('CONNECT ' + IP + ':' + Port + 'HTTP/1.0' + #$0d + #$0a); SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + #$0d + #$0a);
if FHTTPTunnelUser <> '' then if FHTTPTunnelUser <> '' then
Sendstring('Proxy-Authorization: Basic ' + Sendstring('Proxy-Authorization: Basic ' +
EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a); EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a);
SendString(#$0d + #$0a); SendString(#$0d + #$0a);
repeat repeat
s := RecvString(30000); s := RecvTerminated(30000, #$0a);
if FLastError <> 0 then if FLastError <> 0 then
Break; Break;
if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then
FHTTPTunnel := s[10] = '2'; FHTTPTunnel := s[10] = '2';
until s = ''; until (s = '') or (s = #$0d);
if (FLasterror = 0) and not FHTTPTunnel then if (FLasterror = 0) and not FHTTPTunnel then
FLastError := WSASYSNOTREADY; FLastError := WSASYSNOTREADY;
FHTTPTunnelRemoteIP := IP; FHTTPTunnelRemoteIP := IP;
@ -1675,6 +1732,18 @@ begin
Result := inherited GetRemoteSinPort; Result := inherited GetRemoteSinPort;
end; end;
function TTCPBlockSocket.SetSslKeys: boolean;
begin
Result := False;
if FSSLCertificateFile <> '' then
SslCtxUseCertificateChainFile(FCtx, PChar(FSSLCertificateFile));
if FSSLPrivateKeyFile <> '' then
SslCtxUsePrivateKeyFile(FCtx, PChar(FSSLPrivateKeyFile), 1);
if FSSLCertCAFile <> '' then
SslCtxLoadVerifyLocations(FCtx, PChar(FSSLCertCAFile), nil);
Result := True;
end;
procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean); procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean);
begin begin
if Value <> FSslEnabled then if Value <> FSslEnabled then
@ -1682,10 +1751,14 @@ begin
begin begin
if InitSSLInterface then if InitSSLInterface then
begin begin
SslLoadErrorStrings;
SslLibraryInit; SslLibraryInit;
SslLoadErrorStrings;
Fctx := nil; Fctx := nil;
Fctx := SslCtxNew(SslMethodV23); Fctx := SslCtxNew(SslMethodV23);
SslCtxSetCipherList(Fctx, PChar(FSSLCiphers));
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
SetSSLKeys;
Fssl := nil; Fssl := nil;
Fssl := SslNew(Fctx); Fssl := SslNew(Fctx);
FSslEnabled := True; FSslEnabled := True;
@ -1747,18 +1820,14 @@ begin
Result := inherited SendBuffer(Buffer, Length); Result := inherited SendBuffer(Buffer, Length);
end; end;
function TTCPBlockSocket.SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean; function TTCPBlockSocket.SSLAcceptConnection: Boolean;
begin begin
Result := False; Result := False;
FLastError := 0; FLastError := 0;
if SslCtxUseCertificateFile(FCtx, PChar(Certificate), 1) < 0 then if not FSSLEnabled then
SSLEnabled := True;
if sslsetfd(FSsl, FSocket) < 0 then
FLastError := WSASYSNOTREADY; FLastError := WSASYSNOTREADY;
if (FLastError = 0) then
if SslCtxUsePrivateKeyFile(FCtx, PChar(PrivateKey), 1) < 0 then
FLastError := WSASYSNOTREADY;
if (FLastError = 0) then
if sslsetfd(FSsl, FSocket) < 0 then
FLastError := WSASYSNOTREADY;
if (FLastError = 0) then if (FLastError = 0) then
if sslAccept(FSsl) < 0 then if sslAccept(FSsl) < 0 then
FLastError := WSASYSNOTREADY; FLastError := WSASYSNOTREADY;

315
ftpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.002.002 | | Project : Delphree - Synapse | 002.000.000 |
|==============================================================================| |==============================================================================|
| Content: FTP client | | Content: FTP client |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -47,6 +47,27 @@ type
TFTPStatus = procedure(Sender: TObject; Response: Boolean; TFTPStatus = procedure(Sender: TObject; Response: Boolean;
const Value: string) of object; const Value: string) of object;
TFTPListRec = class(TObject)
public
FileName: string;
Directory: Boolean;
Readable: Boolean;
FileSize: Longint;
FileTime: TDateTime;
end;
TFTPList = class(TObject)
private
FList: TList;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function ParseLine(Value: string): Boolean;
published
property List: TList read FList;
end;
TFTPSend = class(TObject) TFTPSend = class(TObject)
private private
FOnStatus: TFTPStatus; FOnStatus: TFTPStatus;
@ -74,6 +95,7 @@ type
FCanResume: Boolean; FCanResume: Boolean;
FPassiveMode: Boolean; FPassiveMode: Boolean;
FForceDefaultPort: Boolean; FForceDefaultPort: Boolean;
FFtpList: TFTPList;
function Auth(Mode: integer): Boolean; function Auth(Mode: integer): Boolean;
function Connect: Boolean; function Connect: Boolean;
function InternalStor(const Command: string; RestoreAt: integer): Boolean; function InternalStor(const Command: string; RestoreAt: integer): Boolean;
@ -132,6 +154,7 @@ type
property PassiveMode: Boolean read FPassiveMode Write FPassiveMode; property PassiveMode: Boolean read FPassiveMode Write FPassiveMode;
property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort; property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort;
property OnStatus: TFTPStatus read FOnStatus write FOnStatus; property OnStatus: TFTPStatus read FOnStatus write FOnStatus;
property FtpList: TFTPList read FFtpList;
end; end;
function FtpGetFile(const IP, Port, FileName, LocalFile, function FtpGetFile(const IP, Port, FileName, LocalFile,
@ -154,6 +177,7 @@ begin
FDataStream := TMemoryStream.Create; FDataStream := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FDSock := TTCPBlockSocket.Create; FDSock := TTCPBlockSocket.Create;
FFtpList := TFTPList.Create;
FTimeout := 300000; FTimeout := 300000;
FFTPHost := cLocalhost; FFTPHost := cLocalhost;
FFTPPort := cFtpProtocol; FFTPPort := cFtpProtocol;
@ -174,6 +198,7 @@ destructor TFTPSend.Destroy;
begin begin
FDSock.Free; FDSock.Free;
FSock.Free; FSock.Free;
FFTPList.Free;
FDataStream.Free; FDataStream.Free;
FFullResult.Free; FFullResult.Free;
inherited Destroy; inherited Destroy;
@ -344,11 +369,12 @@ begin
FTPCommand('TYPE I'); FTPCommand('TYPE I');
FTPCommand('STRU F'); FTPCommand('STRU F');
FTPCommand('MODE S'); FTPCommand('MODE S');
if FTPCommand('REST 1') = 350 then if FTPCommand('REST 0') = 350 then
begin if FTPCommand('REST 1') = 350 then
FTPCommand('REST 0'); begin
FCanResume := True; FTPCommand('REST 0');
end; FCanResume := True;
end;
Result := True; Result := True;
end; end;
@ -508,9 +534,11 @@ end;
function TFTPSend.List(Directory: string; NameList: Boolean): Boolean; function TFTPSend.List(Directory: string; NameList: Boolean): Boolean;
var var
x: integer; x: integer;
l: TStringList;
begin begin
Result := False; Result := False;
FDataStream.Clear; FDataStream.Clear;
FFTPList.Clear;
if Directory <> '' then if Directory <> '' then
Directory := ' ' + Directory; Directory := ' ' + Directory;
if not DataSocket then if not DataSocket then
@ -523,6 +551,18 @@ begin
if (x div 100) <> 1 then if (x div 100) <> 1 then
Exit; Exit;
Result := DataRead(FDataStream); Result := DataRead(FDataStream);
if not NameList then
begin
l := TStringList.Create;
try
FDataStream.Seek(0, soFromBeginning);
l.LoadFromStream(FDataStream);
for x := 0 to l.Count - 1 do
FFTPList.ParseLine(l[x]);
finally
l.Free;
end;
end;
FDataStream.Seek(0, soFromBeginning); FDataStream.Seek(0, soFromBeginning);
end; end;
@ -703,6 +743,267 @@ end;
{==============================================================================} {==============================================================================}
constructor TFTPList.Create;
begin
inherited Create;
FList := TList.Create;
end;
destructor TFTPList.Destroy;
begin
Clear;
FList.Free;
inherited Destroy;
end;
procedure TFTPList.Clear;
var
n:integer;
begin
for n := 0 to FList.Count - 1 do
if Assigned(FList[n]) then
TFTPListRec(FList[n]).Free;
FList.Clear;
end;
// based on idea by D. J. Bernstein, djb@pobox.com
function TFTPList.ParseLine(Value: string): Boolean;
var
flr: TFTPListRec;
s: string;
state: integer;
year: Word;
month: Word;
mday: Word;
t: TDateTime;
x: integer;
begin
Result := False;
if Length(Value) < 2 then
Exit;
year := 0;
month := 0;
mday := 0;
t := 0;
flr := TFTPListRec.Create;
try
flr.FileName := '';
flr.Directory := False;
flr.Readable := False;
flr.FileSize := 0;
flr.FileTime := 0;
Value := Trim(Value);
{EPLF
See http://pobox.com/~djb/proto/eplf.txt
"+i8388621.29609,m824255902,/," + #9 + "tdev"
"+i8388621.44468,m839956783,r,s10376," + #9 + "RFCEPLF" }
if Value[1] = '+' then
begin
s := Fetch(Value, ',');
while s <> '' do
begin
if s[1] = #9 then
begin
flr.FileName := Copy(s, 2, Length(s) - 1);
Result := True;
end;
case s[1] of
'/':
flr.Directory := true;
'r':
flr.Readable := true;
's':
flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0);
'm':
flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400)
+ 25569;
end;
s := Fetch(Value, ',');
end;
Exit;
end;
{UNIX-style listing, without inum and without blocks
Permissions Owner Group Size Date/Time Name
"-rw-r--r-- 1 root other 531 Jan 29 03:26 README"
"dr-xr-xr-x 2 root other 512 Apr 8 1994 etc"
"dr-xr-xr-x 2 root 512 Apr 8 1994 etc"
"lrwxrwxrwx 1 root other 7 Jan 25 00:17 bin -> usr/bin"
Also produced by Microsoft's FTP servers for Windows:
"---------- 1 owner group 1803128 Jul 10 10:18 ls-lR.Z"
Also WFTPD for MSDOS:
"-rwxrwxrwx 1 noone nogroup 322 Aug 19 1996 message.ftp"
Also NetWare:
"d [R----F--] supervisor 512 Jan 16 18:53 login"
"- [R----F--] rhesus 214059 Oct 20 15:27 cx.exe"
Also NetPresenz for the Mac:
"-------r-- 326 1391972 1392298 Nov 22 1995 MegaPhone.sit"
"drwxrwxr-x folder 2 May 10 1996 network" }
if (Value[1] = 'b') or
(Value[1] = 'c') or
(Value[1] = 'd') or
(Value[1] = 'l') or
(Value[1] = 'p') or
(Value[1] = 's') or
(Value[1] = '-') then
begin
if Value[1] = 'd' then
flr.Directory := True;
if Value[1] = '-' then
flr.Readable := True;
if Value[1] = 'l' then
begin
flr.Directory := True;
flr.Readable := True;
end;
state := 1;
s := Fetch(Value, ' ');
while s <> '' do
begin
case state of
1:
begin
state := 2;
if (s[1] = 'f') and (Pos(' ', s) = 6) then
state := 3;
end;
2:
state := 3;
3:
begin
flr.FileSize := StrToIntDef(s, 0);
state := 4;
end;
4:
begin
month := GetMonthNumber(s);
if month > 0 then
state := 5
else
flr.FileSize := StrToIntDef(s, 0);
end;
5:
begin
mday := StrToIntDef(s, 0);
state := 6;
end;
6:
begin
if (Pos(':', s) > 0) then
t := GetTimeFromStr(s)
else
if Length(s) = 4 then
year := StrToIntDef(s, 0)
else Exit;
if (year = 0) or (month = 0) or (mday = 0) then
Exit;
flr.FileTime := t + Encodedate(year, month, mday);
state := 7;
end;
7:
begin
flr.FileName := s;
Result := True;
end;
end;
s := Fetch(Value, ' ');
end;
Exit;
end;
{Microsoft NT 4.0 FTP Service
10-20-98 08:57AM 619098 rizrem.zip
11-12-98 11:54AM <DIR> test }
if (Value[1] = '1') or (Value[1] = '0') then
begin
if Length(Value) < 8 then
Exit;
if (Ord(Value[2]) < 48) or (Ord(Value[2]) > 57) then
Exit;
if Value[3] <> '-' then
Exit;
s := Fetch(Value, ' ');
t := GetDateMDYFromStr(s);
if t = 0 then
Exit;
if Value = '' then
Exit;
s := Fetch(Value, ' ');
flr.FileTime := t + GetTimeFromStr(s);
if Value = '' then
Exit;
s := Fetch(Value, ' ');
if s[1] = '<' then
flr.Directory := True
else
begin
flr.Readable := true;
flr.Filesize := StrToIntDef(s, 0);
end;
if Value = '' then
Exit;
s := Fetch(Value, ' ');
flr.FileName := s;
Result := True;
Exit;
end;
{MultiNet
"00README.TXT;1 2 30-DEC-1996 17:44 [SYSTEM] (RWED,RWED,RE,RE)"
"CORE.DIR;1 1 8-SEP-1996 16:09 [SYSTEM] (RWE,RWE,RE,RE)"
and non-MutliNet VMS:
"CII-MANUAL.TEX;1 213/216 29-JAN-1996 03:33:12 [ANONYMOU,ANONYMOUS] (RWED,RWED,,)" }
x := Pos(';', Value);
if x > 0 then
begin
s := Fetch(Value, ';');
if Uppercase(Copy(s,Length(s) - 4, 4)) = '.DIR' then
begin
flr.FileName := Copy(s, 1, Length(s) - 4);
flr.Directory := True;
end
else
begin
flr.FileName := s;
flr.Readable := True;
end;
s := Fetch(Value, ' ');
s := Fetch(Value, ' ');
if Value = '' then
Exit;
s := Fetch(Value, '-');
mday := StrToIntDef(s, 0);
s := Fetch(Value, '-');
month := GetMonthNumber(s);
s := Fetch(Value, ' ');
year := StrToIntDef(s, 0);
s := Fetch(Value, ' ');
if Value = '' then
Exit;
if (year = 0) or (month = 0) or (mday = 0) then
Exit;
flr.FileTime := GetTimeFromStr(s) + EncodeDate(year, month, mday);
Result := True;
Exit;
end;
finally
if Result then
if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then
Result := False;
if Result then
FList.Add(flr)
else
flr.Free;
end;
end;
{==============================================================================}
function FtpGetFile(const IP, Port, FileName, LocalFile, function FtpGetFile(const IP, Port, FileName, LocalFile,
User, Pass: string): Boolean; User, Pass: string): Boolean;
begin begin

22
httpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 003.000.000 | | Project : Delphree - Synapse | 003.000.003 |
|==============================================================================| |==============================================================================|
| Content: HTTP client | | Content: HTTP client |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -115,7 +115,7 @@ begin
FProxyPass := ''; FProxyPass := '';
FAliveHost := ''; FAliveHost := '';
FAlivePort := ''; FAlivePort := '';
FProtocol := '1.1'; FProtocol := '1.0';
FKeepAlive := True; FKeepAlive := True;
Clear; Clear;
end; end;
@ -254,10 +254,10 @@ begin
end; end;
{ send Headers } { send Headers }
FSock.SendString(Headers[0] + CRLF); if FProtocol = '0.9' then
if FProtocol <> '0.9' then FSock.SendString(FHeaders[0] + CRLF)
for n := 1 to FHeaders.Count - 1 do else
FSock.SendString(FHeaders[n] + CRLF); FSock.SendString(FHeaders.Text);
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Exit; Exit;
@ -470,7 +470,7 @@ begin
HTTP := THTTPSend.Create; HTTP := THTTPSend.Create;
try try
HTTP.Document.Write(Pointer(URLData)^, Length(URLData)); HTTP.Document.Write(Pointer(URLData)^, Length(URLData));
HTTP.MimeType := 'application/x-url-encoded'; HTTP.MimeType := 'application/x-www-form-urlencoded';
Result := HTTP.HTTPMethod('POST', URL); Result := HTTP.HTTPMethod('POST', URL);
Data.CopyFrom(HTTP.Document, 0); Data.CopyFrom(HTTP.Document, 0);
finally finally
@ -486,16 +486,16 @@ var
HTTP: THTTPSend; HTTP: THTTPSend;
Bound, s: string; Bound, s: string;
begin begin
Bound := '--' + IntToHex(Random(MaxInt), 8) + '_Synapse_boundary'; Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
HTTP := THTTPSend.Create; HTTP := THTTPSend.Create;
try try
s := Bound + CRLF; s := '--' + Bound + CRLF;
s := s + 'content-disposition: form-data; name="' + FieldName + '";'; s := s + 'content-disposition: form-data; name="' + FieldName + '";';
s := s + ' filename="' + FileName +'"' + CRLF; s := s + ' filename="' + FileName +'"' + CRLF;
s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF; s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
HTTP.Document.Write(Pointer(s)^, Length(s)); HTTP.Document.Write(Pointer(s)^, Length(s));
HTTP.Document.CopyFrom(Data, 0); HTTP.Document.CopyFrom(Data, 0);
s := CRLF + Bound + '--' + CRLF; s := CRLF + '--' + Bound + '--' + CRLF;
HTTP.Document.Write(Pointer(s)^, Length(s)); HTTP.Document.Write(Pointer(s)^, Length(s));
HTTP.MimeType := 'multipart/form-data, boundary=' + Bound; HTTP.MimeType := 'multipart/form-data, boundary=' + Bound;
Result := HTTP.HTTPMethod('POST', URL); Result := HTTP.HTTPMethod('POST', URL);

76
imapsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.001.001 | | Project : Delphree - Synapse | 002.000.000 |
|==============================================================================| |==============================================================================|
| Content: IMAP4rev1 client | | Content: IMAP4rev1 client |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001. | | Portions created by Lukas Gebauer are Copyright (c)2001-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -26,6 +26,7 @@
{$WEAKPACKAGEUNIT ON} {$WEAKPACKAGEUNIT ON}
//RFC-2060 //RFC-2060
//RFC-2595
unit IMAPsend; unit IMAPsend;
@ -57,7 +58,8 @@ type
FSelectedRecent: integer; FSelectedRecent: integer;
FSelectedUIDvalidity: integer; FSelectedUIDvalidity: integer;
FUID: Boolean; FUID: Boolean;
FAutoTLS: Boolean;
FFullSSL: Boolean;
function ReadResult: string; function ReadResult: string;
function AuthLogin: Boolean; function AuthLogin: Boolean;
function Connect: Boolean; function Connect: Boolean;
@ -70,6 +72,7 @@ type
destructor Destroy; override; destructor Destroy; override;
function IMAPcommand(Value: string): string; function IMAPcommand(Value: string): string;
function IMAPuploadCommand(Value: string; const Data:TStrings): string; function IMAPuploadCommand(Value: string; const Data:TStrings): string;
function Capability: Boolean;
function Login: Boolean; function Login: Boolean;
procedure Logout; procedure Logout;
function NoOp: Boolean; function NoOp: Boolean;
@ -95,7 +98,7 @@ type
function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
function SetFlagsMess(MessID: integer; Flags: string): Boolean; function SetFlagsMess(MessID: integer; Flags: string): Boolean;
function GetFlagsMess(MessID: integer; var Flags: string): Boolean; function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
function StartTLS: Boolean;
function FindCap(const Value: string): string; function FindCap(const Value: string): string;
published published
property Timeout: Integer read FTimeout Write FTimeout; property Timeout: Integer read FTimeout Write FTimeout;
@ -113,6 +116,8 @@ type
property SelectedCount: integer read FSelectedCount; property SelectedCount: integer read FSelectedCount;
property SelectedRecent: integer read FSelectedRecent; property SelectedRecent: integer read FSelectedRecent;
property SelectedUIDvalidity: integer read FSelectedUIDvalidity; property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
property FullSSL: Boolean read FFullSSL Write FFullSSL;
end; end;
implementation implementation
@ -140,6 +145,8 @@ begin
FSelectedRecent := 0; FSelectedRecent := 0;
FSelectedUIDvalidity := 0; FSelectedUIDvalidity := 0;
FUID := False; FUID := False;
FAutoTLS := False;
FFullSSL := False;
end; end;
destructor TIMAPSend.Destroy; destructor TIMAPSend.Destroy;
@ -307,31 +314,18 @@ function TIMAPSend.Connect: Boolean;
begin begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.CreateSocket; FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(FIMAPHost, FIMAPPort); FSock.Connect(FIMAPHost, FIMAPPort);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
function TIMAPSend.Login: Boolean; function TIMAPSend.Capability: Boolean;
var var
n: Integer; n: Integer;
s, t: string; s, t: string;
begin begin
FSelectedFolder := '';
FSelectedCount := 0;
FSelectedRecent := 0;
FSelectedUIDvalidity := 0;
Result := False; Result := False;
FAuthDone := False;
if not Connect then
Exit;
s := FSock.RecvString(FTimeout);
if Pos('* PREAUTH', s) = 1 then
FAuthDone := True
else
if Pos('* OK', s) = 1 then
FAuthDone := False
else
Exit;
FIMAPcap.Clear; FIMAPcap.Clear;
s := IMAPcommand('CAPABILITY'); s := IMAPcommand('CAPABILITY');
if s = 'OK' then if s = 'OK' then
@ -349,8 +343,37 @@ begin
FIMAPcap.Add(t); FIMAPcap.Add(t);
end; end;
end; end;
Result := True;
end;
end;
function TIMAPSend.Login: Boolean;
var
s: string;
begin
FSelectedFolder := '';
FSelectedCount := 0;
FSelectedRecent := 0;
FSelectedUIDvalidity := 0;
Result := False;
FAuthDone := False;
if not Connect then
Exit;
s := FSock.RecvString(FTimeout);
if Pos('* PREAUTH', s) = 1 then
FAuthDone := True
else
if Pos('* OK', s) = 1 then
FAuthDone := False
else
Exit;
if Capability then
begin
if Findcap('IMAP4rev1') = '' then if Findcap('IMAP4rev1') = '' then
Exit; Exit;
if FAutoTLS and (Findcap('STARTTLS') <> '') then
if StartTLS then
Capability;
end; end;
Result := AuthLogin; Result := AuthLogin;
end; end;
@ -570,6 +593,19 @@ begin
end; end;
end; end;
function TIMAPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
if IMAPcommand('STARTTLS') = 'OK' then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
{==============================================================================} {==============================================================================}
end. end.

43
mimemess.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.007.002 | | Project : Delphree - Synapse | 001.007.004 |
|==============================================================================| |==============================================================================|
| Content: MIME message object | | Content: MIME message object |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. | | Portions created by Lukas Gebauer are Copyright (c)2000-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -221,6 +221,18 @@ begin
FDate := DecodeRfcDateTime(SeparateRight(s, ':')); FDate := DecodeRfcDateTime(SeparateRight(s, ':'));
continue; continue;
end; end;
if Pos('MIME-VERSION:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-TYPE:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-DESCRIPTION:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-DISPOSITION:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-ID:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-TRANSFER-ENCODING:', UpperCase(s)) = 1 then
continue;
FCustomHeaders.Add(s); FCustomHeaders.Add(s);
end; end;
end; end;
@ -231,7 +243,7 @@ var
begin begin
Result := ''; Result := '';
for n := 0 to FCustomHeaders.Count - 1 do for n := 0 to FCustomHeaders.Count - 1 do
if Pos(Value, FCustomHeaders[n]) = 1 then if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
begin begin
Result := SeparateRight(FCustomHeaders[n], ':'); Result := SeparateRight(FCustomHeaders[n], ':');
break; break;
@ -244,7 +256,7 @@ var
begin begin
HeaderList.Clear; HeaderList.Clear;
for n := 0 to FCustomHeaders.Count - 1 do for n := 0 to FCustomHeaders.Count - 1 do
if Pos(Value, FCustomHeaders[n]) = 1 then if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
begin begin
HeaderList.Add(SeparateRight(FCustomHeaders[n], ':')); HeaderList.Add(SeparateRight(FCustomHeaders[n], ':'));
end; end;
@ -370,30 +382,35 @@ procedure TMimeMess.EncodeMessage;
var var
bound: string; bound: string;
n: Integer; n: Integer;
m:TMimepart;
begin begin
FLines.Clear; FLines.Clear;
if FPartList.Count = 1 then if FPartList.Count = 1 then
begin
TMimePart(FPartList[0]).EncodePart;
FLines.Assign(TMimePart(FPartList[0]).Lines) FLines.Assign(TMimePart(FPartList[0]).Lines)
end
else else
begin begin
bound := GenerateBoundary; bound := GenerateBoundary;
for n := 0 to FPartList.Count - 1 do for n := 0 to FPartList.Count - 1 do
begin begin
FLines.Add('--' + bound); FLines.Add('--' + bound);
TMimePart(FPartList[n]).EncodePart;
FLines.AddStrings(TMimePart(FPartList[n]).Lines); FLines.AddStrings(TMimePart(FPartList[n]).Lines);
end; end;
FLines.Add('--' + bound + '--'); FLines.Add('--' + bound + '--');
with TMimePart.Create do m := TMimePart.Create;
try try
Self.FLines.SaveToStream(DecodedLines); FLines.SaveToStream(m.DecodedLines);
Primary := 'Multipart'; m.Primary := 'Multipart';
Secondary := FMultipartType; m.Secondary := FMultipartType;
Description := 'Multipart message'; m.Description := 'Multipart message';
Boundary := bound; m.Boundary := bound;
EncodePart; m.EncodePart;
Self.FLines.Assign(Lines); FLines.Assign(m.Lines);
finally finally
Free; m.Free;
end; end;
end; end;
end; end;

32
mimepart.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.008.001 | | Project : Delphree - Synapse | 001.008.004 |
|==============================================================================| |==============================================================================|
| Content: MIME support procedures and functions | | Content: MIME support procedures and functions |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. | | Portions created by Lukas Gebauer are Copyright (c)2000-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -415,6 +415,7 @@ var
l: TStringList; l: TStringList;
s, t: string; s, t: string;
n, x: Integer; n, x: Integer;
d1, d2: integer;
const const
MaxLine = 75; MaxLine = 75;
begin begin
@ -453,10 +454,27 @@ begin
begin begin
s := EncodeQuotedPrintable(s); s := EncodeQuotedPrintable(s);
repeat repeat
t := Copy(s, 1, MaxLine); if Length(s) < MaxLine then
s := Copy(s, MaxLine + 1, Length(s) - MaxLine); begin
if s <> '' then t := s;
t := t + '='; s := '';
end
else
begin
d1 := RPosEx('=', s, MaxLine);
d2 := RPosEx(' ', s, MaxLine);
if (d1 = 0) and (d2 = 0) then
x := MaxLine
else
if d1 > d2 then
x := d1 - 1
else
x := d2 - 1;
t := Copy(s, 1, x);
s := Copy(s, x + 1, Length(s) - x);
if s <> '' then
t := t + '=';
end;
FLines.Add(t); FLines.Add(t);
until s = ''; until s = '';
end end
@ -596,7 +614,7 @@ var
begin begin
Randomize; Randomize;
x := Random(MaxInt); x := Random(MaxInt);
Result := '--' + IntToHex(x, 8) + '_Synapse_message_boundary--'; Result := '--' + IntToHex(x, 8) + '_Synapse_message_boundary';
end; end;
end. end.

64
pop3send.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.002.000 | | Project : Delphree - Synapse | 002.000.000 |
|==============================================================================| |==============================================================================|
| Content: POP3 client | | Content: POP3 client |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001. | | Portions created by Lukas Gebauer are Copyright (c)2001-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -25,6 +25,12 @@
{$WEAKPACKAGEUNIT ON} {$WEAKPACKAGEUNIT ON}
//RFC-1734
//RFC-1939
//RFC-2195
//RFC-2449
//RFC-2595
unit POP3send; unit POP3send;
interface interface
@ -54,6 +60,9 @@ type
FStatSize: Integer; FStatSize: Integer;
FTimeStamp: string; FTimeStamp: string;
FAuthType: TPOP3AuthType; FAuthType: TPOP3AuthType;
FPOP3cap: TStringList;
FAutoTLS: Boolean;
FFullSSL: Boolean;
function ReadResult(Full: Boolean): Integer; function ReadResult(Full: Boolean): Integer;
function Connect: Boolean; function Connect: Boolean;
function AuthLogin: Boolean; function AuthLogin: Boolean;
@ -61,6 +70,7 @@ type
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
function Capability: Boolean;
function Login: Boolean; function Login: Boolean;
procedure Logout; procedure Logout;
function Reset: Boolean; function Reset: Boolean;
@ -71,6 +81,8 @@ type
function Dele(Value: Integer): Boolean; function Dele(Value: Integer): Boolean;
function Top(Value, Maxlines: Integer): Boolean; function Top(Value, Maxlines: Integer): Boolean;
function Uidl(Value: Integer): Boolean; function Uidl(Value: Integer): Boolean;
function StartTLS: Boolean;
function FindCap(const Value: string): string;
published published
property Timeout: Integer read FTimeout Write FTimeout; property Timeout: Integer read FTimeout Write FTimeout;
property POP3Host: string read FPOP3Host Write FPOP3Host; property POP3Host: string read FPOP3Host Write FPOP3Host;
@ -85,6 +97,8 @@ type
property TimeStamp: string read FTimeStamp; property TimeStamp: string read FTimeStamp;
property AuthType: TPOP3AuthType read FAuthType Write FAuthType; property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
property Sock: TTCPBlockSocket read FSock; property Sock: TTCPBlockSocket read FSock;
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
property FullSSL: Boolean read FFullSSL Write FFullSSL;
end; end;
implementation implementation
@ -96,6 +110,7 @@ constructor TPOP3Send.Create;
begin begin
inherited Create; inherited Create;
FFullResult := TStringList.Create; FFullResult := TStringList.Create;
FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.CreateSocket; FSock.CreateSocket;
FTimeout := 300000; FTimeout := 300000;
@ -106,11 +121,14 @@ begin
FStatCount := 0; FStatCount := 0;
FStatSize := 0; FStatSize := 0;
FAuthType := POP3AuthAll; FAuthType := POP3AuthAll;
FAutoTLS := False;
FFullSSL := False;
end; end;
destructor TPOP3Send.Destroy; destructor TPOP3Send.Destroy;
begin begin
FSock.Free; FSock.Free;
FPOP3cap.Free;
FullResult.Free; FullResult.Free;
inherited Destroy; inherited Destroy;
end; end;
@ -162,10 +180,22 @@ begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.LineBuffer := ''; FSock.LineBuffer := '';
FSock.CreateSocket; FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(POP3Host, POP3Port); FSock.Connect(POP3Host, POP3Port);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
function TPOP3Send.Capability: Boolean;
begin
FPOP3cap.Clear;
Result := False;
FSock.SendString('CAPA' + CRLF);
Result := ReadResult(True) = 1;
if Result then
FPOP3cap.AddStrings(FFullResult);
end;
function TPOP3Send.Login: Boolean; function TPOP3Send.Login: Boolean;
var var
s, s1: string; s, s1: string;
@ -184,6 +214,10 @@ begin
FTimeStamp := '<' + s1 + '>'; FTimeStamp := '<' + s1 + '>';
end; end;
Result := False; Result := False;
if Capability then
if FAutoTLS and (Findcap('STLS') <> '') then
if StartTLS then
Capability;
if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
begin begin
Result := AuthApop; Result := AuthApop;
@ -268,4 +302,30 @@ begin
Result := ReadResult(Value = 0) = 1; Result := ReadResult(Value = 0) = 1;
end; end;
function TPOP3Send.StartTLS: Boolean;
begin
Result := False;
FSock.SendString('STLS' + CRLF);
if ReadResult(False) = 1 then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
function TPOP3Send.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FPOP3cap.Count - 1 do
if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
begin
Result := FPOP3cap[n];
Break;
end;
end;
end. end.

42
smtpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.002.000 | | Project : Delphree - Synapse | 003.001.000 |
|==============================================================================| |==============================================================================|
| Content: SMTP client | | Content: SMTP client |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -57,6 +57,8 @@ type
FEnhCode2: Integer; FEnhCode2: Integer;
FEnhCode3: Integer; FEnhCode3: Integer;
FSystemName: string; FSystemName: string;
FAutoTLS: Boolean;
FFullSSL: Boolean;
procedure EnhancedCode(const Value: string); procedure EnhancedCode(const Value: string);
function ReadResult: Integer; function ReadResult: Integer;
function AuthLogin: Boolean; function AuthLogin: Boolean;
@ -76,6 +78,7 @@ type
function MailData(const Value: Tstrings): Boolean; function MailData(const Value: Tstrings): Boolean;
function Etrn(const Value: string): Boolean; function Etrn(const Value: string): Boolean;
function Verify(const Value: string): Boolean; function Verify(const Value: string): Boolean;
function StartTLS: Boolean;
function EnhCodeString: string; function EnhCodeString: string;
function FindCap(const Value: string): string; function FindCap(const Value: string): string;
published published
@ -97,6 +100,8 @@ type
property EnhCode3: Integer read FEnhCode3; property EnhCode3: Integer read FEnhCode3;
property SystemName: string read FSystemName Write FSystemName; property SystemName: string read FSystemName Write FSystemName;
property Sock: TTCPBlockSocket read FSock; property Sock: TTCPBlockSocket read FSock;
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
property FullSSL: Boolean read FFullSSL Write FFullSSL;
end; end;
function SendToRaw(const MailFrom, MailTo, SMTPHost: string; function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
@ -124,6 +129,8 @@ begin
FUsername := ''; FUsername := '';
FPassword := ''; FPassword := '';
FSystemName := FSock.LocalName; FSystemName := FSock.LocalName;
FAutoTLS := False;
FFullSSL := False;
end; end;
destructor TSMTPSend.Destroy; destructor TSMTPSend.Destroy;
@ -223,6 +230,8 @@ function TSMTPSend.Connect: Boolean;
begin begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.CreateSocket; FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(FSMTPHost, FSMTPPort); FSock.Connect(FSMTPHost, FSMTPPort);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
@ -272,6 +281,14 @@ begin
begin begin
for n := 1 to FFullResult.Count - 1 do for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
if StartTLS then
begin
Ehlo;
FESMTPcap.Clear;
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
end;
if not ((FUsername = '') and (FPassword = '')) then if not ((FUsername = '') and (FPassword = '')) then
begin begin
s := FindCap('AUTH '); s := FindCap('AUTH ');
@ -372,6 +389,20 @@ begin
Result := (x >= 250) and (x <= 259); Result := (x >= 250) and (x <= 259);
end; end;
function TSMTPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
FSock.SendString('STARTTLS' + CRLF);
if (ReadResult = 220) and (FSock.LastError = 0) then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
function TSMTPSend.EnhCodeString: string; function TSMTPSend.EnhCodeString: string;
var var
s, t: string; s, t: string;
@ -460,6 +491,13 @@ begin
Result := False; Result := False;
SMTP := TSMTPSend.Create; SMTP := TSMTPSend.Create;
try try
// if you need SOCKS5 support, uncomment next lines:
// SMTP.Sock.SocksIP := '127.0.0.1';
// SMTP.Sock.SocksPort := '1080';
// if you need support for upgrade session to TSL/SSL, uncomment next lines:
// SMTP.AutoTLS := True;
// if you need support for TSL/SSL tunnel, uncomment next lines:
// SMTP.FullSSL := True;
SMTP.SMTPHost := SeparateLeft(SMTPHost, ':'); SMTP.SMTPHost := SeparateLeft(SMTPHost, ':');
s := SeparateRight(SMTPHost, ':'); s := SeparateRight(SMTPHost, ':');
if (s <> '') and (s <> SMTPHost) then if (s <> '') and (s <> SMTPHost) then

15
synacode.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.005.003 | | Project : Delphree - Synapse | 001.005.005 |
|==============================================================================| |==============================================================================|
| Content: Coding and decoding support | | Content: Coding and decoding support |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000, 2001. | | Portions created by Lukas Gebauer are Copyright (c)2000-2002. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -239,11 +239,10 @@ begin
begin begin
s := Copy(Value, x, 2); s := Copy(Value, x, 2);
Inc(x, 2); Inc(x, 2);
if pos(#13, s) + pos(#10, s) = 0 then Result[l] := Char(StrToIntDef('$' + s, 32))
Result[l] := Char(StrToIntDef('$' + s, 32)) end
else else
Result[l] := ' '; break;
end;
Inc(l); Inc(l);
end; end;
Dec(l); Dec(l);
@ -340,7 +339,7 @@ begin
begin begin
y := Pos(Value[x], Table); y := Pos(Value[x], Table);
if y < 1 then if y < 1 then
y := 65; y := 1;
d[n] := y - 1; d[n] := y - 1;
end; end;
Inc(x); Inc(x);

23
SynaSSL.pas → synassl.pas.x
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.001.001 | | Project : Delphree - Synapse | 001.004.000 |
|==============================================================================| |==============================================================================|
| Content: SSL support | | Content: SSL support |
|==============================================================================| |==============================================================================|
@ -39,7 +39,8 @@ const
DLLSSLName = 'libssl.so'; DLLSSLName = 'libssl.so';
DLLUtilName = 'libcrypto.so'; DLLUtilName = 'libcrypto.so';
{$ELSE} {$ELSE}
DLLSSLName = 'ssleay32.dll'; DLLSSLName = 'libssl32.dll';
DLLSSLName2 = 'ssleay32.dll';
DLLUtilName = 'libeay32.dll'; DLLUtilName = 'libeay32.dll';
{$ENDIF} {$ENDIF}
@ -57,6 +58,10 @@ const
SSL_ERROR_WANT_READ = 2; SSL_ERROR_WANT_READ = 2;
SSL_ERROR_WANT_WRITE = 3; SSL_ERROR_WANT_WRITE = 3;
SSL_ERROR_ZERO_RETURN = 6; SSL_ERROR_ZERO_RETURN = 6;
SSL_OP_NO_SSLv2 = $01000000;
SSL_OP_NO_SSLv3 = $02000000;
SSL_OP_NO_TLSv1 = $04000000;
SSL_OP_ALL = $000FFFFF;
var var
SSLLibHandle: Integer = 0; SSLLibHandle: Integer = 0;
@ -72,7 +77,11 @@ var
SslSetFd : function(s: PSSL; fd: Integer):Integer cdecl = nil; SslSetFd : function(s: PSSL; fd: Integer):Integer cdecl = nil;
SslMethodV23 : function:PSSL_METHOD cdecl = nil; SslMethodV23 : function:PSSL_METHOD cdecl = nil;
SslCtxUsePrivateKeyFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil; SslCtxUsePrivateKeyFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil;
SslCtxUseCertificateFile : function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer cdecl = nil; SslCtxUseCertificateChainFile : function(ctx: PSSL_CTX; const _file: PChar):Integer cdecl = nil;
SslCtxCheckPrivateKeyFile : function(ctx: PSSL_CTX):Integer cdecl = nil;
SslCtxSetDefaultPasswdCb : procedure(ctx: PSSL_CTX; cb: Pointer) cdecl = nil;
SslCtxSetDefaultPasswdCbUserdata : procedure(ctx: PSSL_CTX; u: Pointer) cdecl = nil;
SslCtxLoadVerifyLocations : function(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer cdecl = nil;
SslNew : function(ctx: PSSL_CTX):PSSL cdecl = nil; SslNew : function(ctx: PSSL_CTX):PSSL cdecl = nil;
SslFree : procedure(ssl: PSSL) cdecl = nil; SslFree : procedure(ssl: PSSL) cdecl = nil;
SslAccept : function(ssl: PSSL):Integer cdecl = nil; SslAccept : function(ssl: PSSL):Integer cdecl = nil;
@ -116,6 +125,8 @@ begin
SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL)); SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL));
{$ELSE} {$ELSE}
SSLLibHandle := LoadLibrary(PChar(DLLSSLName)); SSLLibHandle := LoadLibrary(PChar(DLLSSLName));
if (SSLLibHandle = 0) then
SSLLibHandle := LoadLibrary(PChar(DLLSSLName2));
SSLUtilHandle := LoadLibrary(PChar(DLLUtilName)); SSLUtilHandle := LoadLibrary(PChar(DLLUtilName));
{$ENDIF} {$ENDIF}
if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then
@ -129,7 +140,11 @@ begin
SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd')); SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd'));
SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method')); SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method'));
SslCtxUsePrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_PrivateKey_file')); SslCtxUsePrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_PrivateKey_file'));
SslCtxUseCertificateFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_certificate_file')); SslCtxUseCertificateChainFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_certificate_chain_file'));
SslCtxCheckPrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_check_private_key'));
SslCtxSetDefaultPasswdCb := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_default_passwd_cb'));
SslCtxSetDefaultPasswdCbUserdata := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_default_passwd_cb_userdata'));
SslCtxLoadVerifyLocations := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_load_verify_locations'));
SslNew := GetProcAddress(SSLLibHandle, PChar('SSL_new')); SslNew := GetProcAddress(SSLLibHandle, PChar('SSL_new'));
SslFree := GetProcAddress(SSLLibHandle, PChar('SSL_free')); SslFree := GetProcAddress(SSLLibHandle, PChar('SSL_free'));
SslAccept := GetProcAddress(SSLLibHandle, PChar('SSL_accept')); SslAccept := GetProcAddress(SSLLibHandle, PChar('SSL_accept'));

226
synautil.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.008.001 | | Project : Delphree - Synapse | 002.011.001 |
|==============================================================================| |==============================================================================|
| Content: support procedures and functions | | Content: support procedures and functions |
|==============================================================================| |==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
| Portions created by Hernan Sanchez are Copyright (c) 2000. | | Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
@ -44,6 +44,10 @@ function TimeZone: string;
function Rfc822DateTime(t: TDateTime): string; function Rfc822DateTime(t: TDateTime): string;
function CDateTime(t: TDateTime): string; function CDateTime(t: TDateTime): string;
function SimpleDateTime(t: TDateTime): string; function SimpleDateTime(t: TDateTime): string;
function AnsiCDateTime(t: TDateTime): string;
function GetMonthNumber(Value: string): integer;
function GetTimeFromStr(Value: string): TDateTime;
function GetDateMDYFromStr(Value: string): TDateTime;
function DecodeRfcDateTime(Value: string): TDateTime; function DecodeRfcDateTime(Value: string): TDateTime;
function GetUTTime: TDateTime; function GetUTTime: TDateTime;
function SetUTTime(Newdt: TDateTime): Boolean; function SetUTTime(Newdt: TDateTime): Boolean;
@ -66,6 +70,7 @@ function BinToInt(const Value: string): Integer;
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
Para: string): string; Para: string): string;
function StringReplace(Value, Search, Replace: string): string; function StringReplace(Value, Search, Replace: string): string;
function RPosEx(const Sub, Value: string; From: integer): Integer;
function RPos(const Sub, Value: String): Integer; function RPos(const Sub, Value: String): Integer;
function Fetch(var Value: string; const Delimiter: string): string; function Fetch(var Value: string; const Delimiter: string): string;
@ -194,6 +199,18 @@ end;
{==============================================================================} {==============================================================================}
function AnsiCDateTime(t: TDateTime): string;
begin
SaveNames;
try
Result := FormatDateTime('ddd mmm d hh:nn:ss yyyy', t);
finally
RestoreNames;
end;
end;
{==============================================================================}
function DecodeTimeZone(Value: string; var Zone: integer): Boolean; function DecodeTimeZone(Value: string; var Zone: integer): Boolean;
var var
x: integer; x: integer;
@ -281,98 +298,142 @@ end;
{==============================================================================} {==============================================================================}
function GetMonthNumber(Value: string): integer;
var
n: integer;
begin
Result := 0;
Value := Uppercase(Value);
for n := 1 to 12 do
if Value = uppercase(MyMonthNames[n]) then
begin
Result := n;
Break;
end;
end;
{==============================================================================}
function GetTimeFromStr(Value: string): TDateTime;
var
SaveSeparator: char;
begin
SaveSeparator := TimeSeparator;
try
TimeSeparator := ':';
Result := 0;
try
Result := StrToTime(Value);
except
on Exception do ;
end;
finally
TimeSeparator := SaveSeparator;
end;
end;
{==============================================================================}
function GetDateMDYFromStr(Value: string): TDateTime;
var
SaveSeparator: char;
SaveFormat: string;
begin
SaveSeparator := DateSeparator;
SaveFormat := ShortDateFormat;
try
DateSeparator := '-';
ShortDateFormat := 'm-d-y';
Result := 0;
try
Result := StrToDate(Value);
except
on Exception do ;
end;
finally
ShortDateFormat := SaveFormat;
DateSeparator := SaveSeparator;
end;
end;
{==============================================================================}
function DecodeRfcDateTime(Value: string): TDateTime; function DecodeRfcDateTime(Value: string): TDateTime;
var var
day, month, year: Word; day, month, year: Word;
zone: integer; zone: integer;
x: integer; x: integer;
s: string; s: string;
SaveSeparator: char;
n: integer;
t: TDateTime; t: TDateTime;
begin begin
// ddd, d mmm yyyy hh:mm:ss // ddd, d mmm yyyy hh:mm:ss
// ddd, d mmm yy hh:mm:ss // ddd, d mmm yy hh:mm:ss
// ddd, mmm d yyyy hh:mm:ss // ddd, mmm d yyyy hh:mm:ss
// ddd mmm dd hh:mm:ss yyyy // ddd mmm dd hh:mm:ss yyyy
// Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 // Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123
// Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 // Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format // Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format
Result := 0; Result := 0;
SaveSeparator := TimeSeparator; if Value = '' then
try Exit;
TimeSeparator := ':'; day := 0;
day := 0; month := 0;
month := 0; year := 0;
year := 0; zone := 0;
zone := 0; Value := StringReplace(Value, ' -', ' #');
Value := StringReplace(Value, ' -', ' #'); Value := StringReplace(Value, '-', ' ');
Value := StringReplace(Value, '-', ' '); Value := StringReplace(Value, ' #', ' -');
Value := StringReplace(Value, ' #', ' -'); while Value <> '' do
while Value <> '' do begin
s := Fetch(Value, ' ');
s := uppercase(s);
// timezone
if DecodetimeZone(s, x) then
begin begin
s := Fetch(Value, ' '); zone := x;
s := uppercase(s); continue;
// timezone
if DecodetimeZone(s, x) then
begin
zone := x;
continue;
end;
x := StrToIntDef(s, 0);
// day or year
if x > 0 then
if (x < 32) and (day = 0) then
begin
day := x;
continue;
end
else
begin
year := x;
if year < 32 then
year := year + 2000;
if year < 1000 then
year := year + 1900;
continue;
end;
// time
if rpos(':', s) > Pos(':', s) then
begin
t := 0;
try
t := StrToTime(s);
except
on Exception do ;
end;
if t <> 0 then
Result := t;
continue;
end;
//timezone daylight saving time
if s = 'DST' then
begin
zone := zone + 60;
continue;
end;
// month
for n := 1 to 12 do
if s = uppercase(MyMonthNames[n]) then
begin
month := n;
break;
end;
end; end;
Result := Result + Encodedate(year, month, day); x := StrToIntDef(s, 0);
zone := zone - TimeZoneBias; // day or year
t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); if x > 0 then
if zone < 0 then if (x < 32) and (day = 0) then
t := 0 - t; begin
Result := Result - t; day := x;
finally continue;
TimeSeparator := SaveSeparator; end
else
begin
year := x;
if year < 32 then
year := year + 2000;
if year < 1000 then
year := year + 1900;
continue;
end;
// time
if rpos(':', s) > Pos(':', s) then
begin
t := GetTimeFromStr(s);
if t <> 0 then
Result := t;
continue;
end;
//timezone daylight saving time
if s = 'DST' then
begin
zone := zone + 60;
continue;
end;
// month
month := GetMonthNumber(s);
end; end;
Result := Result + Encodedate(year, month, day);
zone := zone - TimeZoneBias;
t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
if zone < 0 then
t := 0 - t;
Result := Result - t;
end; end;
{==============================================================================} {==============================================================================}
@ -836,14 +897,14 @@ end;
{==============================================================================} {==============================================================================}
function RPos(const Sub, Value: String): Integer; function RPosEx(const Sub, Value: string; From: integer): Integer;
var var
n: Integer; n: Integer;
l: Integer; l: Integer;
begin begin
result := 0; result := 0;
l := Length(Sub); l := Length(Sub);
for n := Length(Value) - l + 1 downto 1 do for n := From - l + 1 downto 1 do
begin begin
if Copy(Value, n, l) = Sub then if Copy(Value, n, l) = Sub then
begin begin
@ -855,6 +916,13 @@ end;
{==============================================================================} {==============================================================================}
function RPos(const Sub, Value: String): Integer;
begin
Result := RPosEx(Sub, Value, Length(Value));
end;
{==============================================================================}
function Fetch(var Value: string; const Delimiter: string): string; function Fetch(var Value: string; const Delimiter: string): string;
var var
s: string; s: string;