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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -90,6 +90,7 @@ type
FSocket: TSocket;
FProtocol: Integer;
procedure CreateSocket; virtual;
procedure AutoCreateSocket;
procedure SetSin(var Sin: TSockAddrIn; IP, Port: string);
function GetSinIP(Sin: TSockAddrIn): string;
function GetSinPort(Sin: TSockAddrIn): Integer;
@ -201,6 +202,11 @@ type
FSslBypass: Boolean;
FSsl: PSSL;
Fctx: PSSL_CTX;
FSSLPassword: string;
FSSLCiphers: string;
FSSLCertificateFile: string;
FSSLPrivateKeyFile: string;
FSSLCertCAFile: string;
FHTTPTunnelIP: string;
FHTTPTunnelPort: string;
FHTTPTunnel: Boolean;
@ -209,6 +215,7 @@ type
FHTTPTunnelUser: string;
FHTTPTunnelPass: string;
procedure SetSslEnabled(Value: Boolean);
function SetSslKeys: boolean;
procedure SocksDoConnect(IP, Port: string);
procedure HTTPTunnelDoConnect(IP, Port: string);
public
@ -221,7 +228,7 @@ type
procedure Connect(IP, Port: string); override;
procedure SSLDoConnect;
procedure SSLDoShutdown;
function SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean;
function SSLAcceptConnection: Boolean;
function GetLocalSinIP: string; override;
function GetRemoteSinIP: string; override;
function GetLocalSinPort: Integer; override;
@ -237,6 +244,11 @@ type
published
property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled;
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 HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort;
property HTTPTunnel: Boolean read FHTTPTunnel;
@ -348,6 +360,8 @@ begin
end;
procedure TBlockSocket.SetSin(var Sin: TSockAddrIn; IP, Port: string);
type
pu_long = ^u_long;
var
ProtoEnt: PProtoEnt;
ServEnt: PServEnt;
@ -373,10 +387,10 @@ begin
begin
HostEnt := synsock.GetHostByName(PChar(IP));
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;
DoStatus(HR_ResolvingEnd, IP+':'+Port);
DoStatus(HR_ResolvingEnd, IP + ':' + Port);
end;
function TBlockSocket.GetSinIP(Sin: TSockAddrIn): string;
@ -406,10 +420,17 @@ begin
DoStatus(HR_SocketCreate, '');
end;
procedure TBlockSocket.AutoCreateSocket;
begin
if FSocket = INVALID_SOCKET then
CreateSocket;
end;
procedure TBlockSocket.CloseSocket;
begin
synsock.Shutdown(FSocket, 2);
synsock.CloseSocket(FSocket);
FSocket := INVALID_SOCKET;
DoStatus(HR_SocketClose, '');
end;
@ -418,6 +439,7 @@ var
Sin: TSockAddrIn;
Len: Integer;
begin
AutoCreateSocket;
SetSin(Sin, IP, Port);
SockCheck(synsock.Bind(FSocket, Sin, SizeOf(Sin)));
Len := SizeOf(FLocalSin);
@ -431,6 +453,7 @@ procedure TBlockSocket.Connect(IP, Port: string);
var
Sin: TSockAddrIn;
begin
AutoCreateSocket;
SetSin(Sin, IP, Port);
SockCheck(synsock.Connect(FSocket, Sin, SizeOf(Sin)));
GetSins;
@ -452,13 +475,18 @@ end;
procedure TBlockSocket.LimitBandwidth(Length: Integer);
var
x: Cardinal;
y: integer;
begin
if FMaxBandwidth > 0 then
begin
x := FNextSend - GetTick;
if x > 0 then
Sleep(x);
FNextSend := GetTick + Trunc((FMaxBandwidth / 1000) * Length);
y:= GetTick;
if FNextSend > y then
begin
x:= FNextSend - y;
if x > 0 then
sleep(x);
end;
FNextSend:= y + Trunc((Length / FMaxBandwidth) * 1000);
end;
end;
@ -557,7 +585,6 @@ end;
function TBlockSocket.RecvPacket(Timeout: Integer): string;
var
x: integer;
s: string;
begin
Result := '';
FLastError := 0;
@ -573,9 +600,9 @@ begin
x := WaitingData;
if x > 0 then
begin
SetLength(s, x);
x := RecvBuffer(Pointer(s), x);
Result := Copy(s, 1, x);
SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x);
SetLength(Result, x);
end;
end
else
@ -587,59 +614,63 @@ end;
function TBlockSocket.RecvByte(Timeout: Integer): Byte;
var
s: String;
begin
Result := 0;
if CanRead(Timeout) then
begin
SetLength(s, 1);
RecvBuffer(Pointer(s), 1);
if s <> '' then
Result := Ord(s[1]);
end
else
FLastError := 0;
if FBuffer = '' then
FBuffer := RecvPacket(Timeout);
if (FBuffer = '') and (FLastError = 0) then
FLastError := WSAETIMEDOUT;
if FLastError = 0 then
begin
Result := Ord(FBuffer[1]);
System.Delete(FBuffer, 1, 1);
end;
ExceptCheck;
end;
function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: string): string;
const
MaxSize = 1024;
var
x: Integer;
s: string;
l: Integer;
begin
s := '';
l := Length(Terminator);
FLastError := 0;
Result := '';
l := system.Length(Terminator);
if l = 0 then
Exit;
FLastError := 0;
repeat
x := 0;
if FBuffer = '' then
begin
FBuffer := RecvPacket(Timeout);
if FLastError <> 0 then
Break;
end;
s := s + FBuffer;
FBuffer := '';
x := Pos(Terminator, s);
// if FBuffer contains requested data, return it...
if FBuffer<>'' then
begin
x := pos(Terminator, FBuffer);
if x > 0 then
begin
FBuffer := Copy(s, x + l, Length(s) - x - l + 1);
s := Copy(s, 1, x - 1);
Result := copy(FBuffer, 1, x - 1);
System.Delete(FBuffer, 1, x + l - 1);
exit;
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
FLastError := WSAENOBUFS;
Break;
end;
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;
end;
@ -1341,6 +1372,7 @@ end;
procedure TUDPBlockSocket.Connect(IP, Port: string);
begin
AutoCreateSocket;
SetRemoteSin(IP, Port);
FBuffer := '';
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;
begin
inherited Create;
FSslEnabled := False;
FSslBypass := False;
FSSLCiphers := 'DEFAULT';
FSSLCertificateFile := '';
FSSLPrivateKeyFile := '';
FSSLPassword := '';
FSsl := nil;
Fctx := nil;
FHTTPTunnelIP := '';
@ -1554,6 +1604,7 @@ end;
procedure TTCPBlockSocket.Connect(IP, Port: string);
begin
AutoCreateSocket;
if FSocksIP <> '' then
SocksDoConnect(IP, Port)
else
@ -1570,41 +1621,47 @@ var
b: Boolean;
begin
inherited Connect(FSocksIP, FSocksPort);
b := SocksOpen;
if b then
b := SocksRequest(1, IP, Port);
if b then
b := SocksResponse;
if not b and (FLastError = 0) then
FLastError := WSASYSNOTREADY;
FSocksLocalIP := FSocksResponseIP;
FSocksLocalPort := FSocksResponsePort;
FSocksRemoteIP := IP;
FSocksRemotePort := Port;
if FLastError = 0 then
begin
b := SocksOpen;
if b then
b := SocksRequest(1, IP, Port);
if b then
b := SocksResponse;
if not b and (FLastError = 0) then
FLastError := WSASYSNOTREADY;
FSocksLocalIP := FSocksResponseIP;
FSocksLocalPort := FSocksResponsePort;
FSocksRemoteIP := IP;
FSocksRemotePort := Port;
end;
ExceptCheck;
DoStatus(HR_Connect, IP + ':' + Port);
end;
procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string);
//bugfixed by Mike Green (mgreen@emixode.com)
var
s: string;
begin
try
FBypassFlag := True;
inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort);
if FLastError <> 0 then
Exit;
FHTTPTunnel := False;
SendString('CONNECT ' + IP + ':' + Port + 'HTTP/1.0' + #$0d + #$0a);
SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + #$0d + #$0a);
if FHTTPTunnelUser <> '' then
Sendstring('Proxy-Authorization: Basic ' +
EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a);
SendString(#$0d + #$0a);
repeat
s := RecvString(30000);
s := RecvTerminated(30000, #$0a);
if FLastError <> 0 then
Break;
if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then
FHTTPTunnel := s[10] = '2';
until s = '';
until (s = '') or (s = #$0d);
if (FLasterror = 0) and not FHTTPTunnel then
FLastError := WSASYSNOTREADY;
FHTTPTunnelRemoteIP := IP;
@ -1675,6 +1732,18 @@ begin
Result := inherited GetRemoteSinPort;
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);
begin
if Value <> FSslEnabled then
@ -1682,10 +1751,14 @@ begin
begin
if InitSSLInterface then
begin
SslLoadErrorStrings;
SslLibraryInit;
SslLoadErrorStrings;
Fctx := nil;
Fctx := SslCtxNew(SslMethodV23);
SslCtxSetCipherList(Fctx, PChar(FSSLCiphers));
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
SetSSLKeys;
Fssl := nil;
Fssl := SslNew(Fctx);
FSslEnabled := True;
@ -1747,18 +1820,14 @@ begin
Result := inherited SendBuffer(Buffer, Length);
end;
function TTCPBlockSocket.SSLAcceptConnection(const PrivateKey, Certificate: string): Boolean;
function TTCPBlockSocket.SSLAcceptConnection: Boolean;
begin
Result := False;
FLastError := 0;
if SslCtxUseCertificateFile(FCtx, PChar(Certificate), 1) < 0 then
if not FSSLEnabled then
SSLEnabled := True;
if sslsetfd(FSsl, FSocket) < 0 then
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 sslAccept(FSsl) < 0 then
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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -47,6 +47,27 @@ type
TFTPStatus = procedure(Sender: TObject; Response: Boolean;
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)
private
FOnStatus: TFTPStatus;
@ -74,6 +95,7 @@ type
FCanResume: Boolean;
FPassiveMode: Boolean;
FForceDefaultPort: Boolean;
FFtpList: TFTPList;
function Auth(Mode: integer): Boolean;
function Connect: Boolean;
function InternalStor(const Command: string; RestoreAt: integer): Boolean;
@ -132,6 +154,7 @@ type
property PassiveMode: Boolean read FPassiveMode Write FPassiveMode;
property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort;
property OnStatus: TFTPStatus read FOnStatus write FOnStatus;
property FtpList: TFTPList read FFtpList;
end;
function FtpGetFile(const IP, Port, FileName, LocalFile,
@ -154,6 +177,7 @@ begin
FDataStream := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FDSock := TTCPBlockSocket.Create;
FFtpList := TFTPList.Create;
FTimeout := 300000;
FFTPHost := cLocalhost;
FFTPPort := cFtpProtocol;
@ -174,6 +198,7 @@ destructor TFTPSend.Destroy;
begin
FDSock.Free;
FSock.Free;
FFTPList.Free;
FDataStream.Free;
FFullResult.Free;
inherited Destroy;
@ -344,11 +369,12 @@ begin
FTPCommand('TYPE I');
FTPCommand('STRU F');
FTPCommand('MODE S');
if FTPCommand('REST 1') = 350 then
begin
FTPCommand('REST 0');
FCanResume := True;
end;
if FTPCommand('REST 0') = 350 then
if FTPCommand('REST 1') = 350 then
begin
FTPCommand('REST 0');
FCanResume := True;
end;
Result := True;
end;
@ -508,9 +534,11 @@ end;
function TFTPSend.List(Directory: string; NameList: Boolean): Boolean;
var
x: integer;
l: TStringList;
begin
Result := False;
FDataStream.Clear;
FFTPList.Clear;
if Directory <> '' then
Directory := ' ' + Directory;
if not DataSocket then
@ -523,6 +551,18 @@ begin
if (x div 100) <> 1 then
Exit;
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);
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,
User, Pass: string): Boolean;
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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -115,7 +115,7 @@ begin
FProxyPass := '';
FAliveHost := '';
FAlivePort := '';
FProtocol := '1.1';
FProtocol := '1.0';
FKeepAlive := True;
Clear;
end;
@ -254,10 +254,10 @@ begin
end;
{ send Headers }
FSock.SendString(Headers[0] + CRLF);
if FProtocol <> '0.9' then
for n := 1 to FHeaders.Count - 1 do
FSock.SendString(FHeaders[n] + CRLF);
if FProtocol = '0.9' then
FSock.SendString(FHeaders[0] + CRLF)
else
FSock.SendString(FHeaders.Text);
if FSock.LastError <> 0 then
Exit;
@ -470,7 +470,7 @@ begin
HTTP := THTTPSend.Create;
try
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);
Data.CopyFrom(HTTP.Document, 0);
finally
@ -486,16 +486,16 @@ var
HTTP: THTTPSend;
Bound, s: string;
begin
Bound := '--' + IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
HTTP := THTTPSend.Create;
try
s := Bound + CRLF;
s := '--' + Bound + CRLF;
s := s + 'content-disposition: form-data; name="' + FieldName + '";';
s := s + ' filename="' + FileName +'"' + CRLF;
s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
HTTP.Document.Write(Pointer(s)^, Length(s));
HTTP.Document.CopyFrom(Data, 0);
s := CRLF + Bound + '--' + CRLF;
s := CRLF + '--' + Bound + '--' + CRLF;
HTTP.Document.Write(Pointer(s)^, Length(s));
HTTP.MimeType := 'multipart/form-data, boundary=' + Bound;
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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -26,6 +26,7 @@
{$WEAKPACKAGEUNIT ON}
//RFC-2060
//RFC-2595
unit IMAPsend;
@ -57,7 +58,8 @@ type
FSelectedRecent: integer;
FSelectedUIDvalidity: integer;
FUID: Boolean;
FAutoTLS: Boolean;
FFullSSL: Boolean;
function ReadResult: string;
function AuthLogin: Boolean;
function Connect: Boolean;
@ -70,6 +72,7 @@ type
destructor Destroy; override;
function IMAPcommand(Value: string): string;
function IMAPuploadCommand(Value: string; const Data:TStrings): string;
function Capability: Boolean;
function Login: Boolean;
procedure Logout;
function NoOp: Boolean;
@ -95,7 +98,7 @@ type
function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
function SetFlagsMess(MessID: integer; Flags: string): Boolean;
function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
function StartTLS: Boolean;
function FindCap(const Value: string): string;
published
property Timeout: Integer read FTimeout Write FTimeout;
@ -113,6 +116,8 @@ type
property SelectedCount: integer read FSelectedCount;
property SelectedRecent: integer read FSelectedRecent;
property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
property FullSSL: Boolean read FFullSSL Write FFullSSL;
end;
implementation
@ -140,6 +145,8 @@ begin
FSelectedRecent := 0;
FSelectedUIDvalidity := 0;
FUID := False;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TIMAPSend.Destroy;
@ -307,31 +314,18 @@ function TIMAPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(FIMAPHost, FIMAPPort);
Result := FSock.LastError = 0;
end;
function TIMAPSend.Login: Boolean;
function TIMAPSend.Capability: Boolean;
var
n: Integer;
s, t: 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;
FIMAPcap.Clear;
s := IMAPcommand('CAPABILITY');
if s = 'OK' then
@ -349,8 +343,37 @@ begin
FIMAPcap.Add(t);
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
Exit;
if FAutoTLS and (Findcap('STARTTLS') <> '') then
if StartTLS then
Capability;
end;
Result := AuthLogin;
end;
@ -570,6 +593,19 @@ begin
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.

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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -221,6 +221,18 @@ begin
FDate := DecodeRfcDateTime(SeparateRight(s, ':'));
continue;
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);
end;
end;
@ -231,7 +243,7 @@ var
begin
Result := '';
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
Result := SeparateRight(FCustomHeaders[n], ':');
break;
@ -244,7 +256,7 @@ var
begin
HeaderList.Clear;
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
HeaderList.Add(SeparateRight(FCustomHeaders[n], ':'));
end;
@ -370,30 +382,35 @@ procedure TMimeMess.EncodeMessage;
var
bound: string;
n: Integer;
m:TMimepart;
begin
FLines.Clear;
if FPartList.Count = 1 then
begin
TMimePart(FPartList[0]).EncodePart;
FLines.Assign(TMimePart(FPartList[0]).Lines)
end
else
begin
bound := GenerateBoundary;
for n := 0 to FPartList.Count - 1 do
begin
FLines.Add('--' + bound);
TMimePart(FPartList[n]).EncodePart;
FLines.AddStrings(TMimePart(FPartList[n]).Lines);
end;
FLines.Add('--' + bound + '--');
with TMimePart.Create do
m := TMimePart.Create;
try
Self.FLines.SaveToStream(DecodedLines);
Primary := 'Multipart';
Secondary := FMultipartType;
Description := 'Multipart message';
Boundary := bound;
EncodePart;
Self.FLines.Assign(Lines);
FLines.SaveToStream(m.DecodedLines);
m.Primary := 'Multipart';
m.Secondary := FMultipartType;
m.Description := 'Multipart message';
m.Boundary := bound;
m.EncodePart;
FLines.Assign(m.Lines);
finally
Free;
m.Free;
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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -415,6 +415,7 @@ var
l: TStringList;
s, t: string;
n, x: Integer;
d1, d2: integer;
const
MaxLine = 75;
begin
@ -453,10 +454,27 @@ begin
begin
s := EncodeQuotedPrintable(s);
repeat
t := Copy(s, 1, MaxLine);
s := Copy(s, MaxLine + 1, Length(s) - MaxLine);
if s <> '' then
t := t + '=';
if Length(s) < MaxLine then
begin
t := s;
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);
until s = '';
end
@ -596,7 +614,7 @@ var
begin
Randomize;
x := Random(MaxInt);
Result := '--' + IntToHex(x, 8) + '_Synapse_message_boundary--';
Result := '--' + IntToHex(x, 8) + '_Synapse_message_boundary';
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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -25,6 +25,12 @@
{$WEAKPACKAGEUNIT ON}
//RFC-1734
//RFC-1939
//RFC-2195
//RFC-2449
//RFC-2595
unit POP3send;
interface
@ -54,6 +60,9 @@ type
FStatSize: Integer;
FTimeStamp: string;
FAuthType: TPOP3AuthType;
FPOP3cap: TStringList;
FAutoTLS: Boolean;
FFullSSL: Boolean;
function ReadResult(Full: Boolean): Integer;
function Connect: Boolean;
function AuthLogin: Boolean;
@ -61,6 +70,7 @@ type
public
constructor Create;
destructor Destroy; override;
function Capability: Boolean;
function Login: Boolean;
procedure Logout;
function Reset: Boolean;
@ -71,6 +81,8 @@ type
function Dele(Value: Integer): Boolean;
function Top(Value, Maxlines: Integer): Boolean;
function Uidl(Value: Integer): Boolean;
function StartTLS: Boolean;
function FindCap(const Value: string): string;
published
property Timeout: Integer read FTimeout Write FTimeout;
property POP3Host: string read FPOP3Host Write FPOP3Host;
@ -85,6 +97,8 @@ type
property TimeStamp: string read FTimeStamp;
property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
property Sock: TTCPBlockSocket read FSock;
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
property FullSSL: Boolean read FFullSSL Write FFullSSL;
end;
implementation
@ -96,6 +110,7 @@ constructor TPOP3Send.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 300000;
@ -106,11 +121,14 @@ begin
FStatCount := 0;
FStatSize := 0;
FAuthType := POP3AuthAll;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TPOP3Send.Destroy;
begin
FSock.Free;
FPOP3cap.Free;
FullResult.Free;
inherited Destroy;
end;
@ -162,10 +180,22 @@ begin
FSock.CloseSocket;
FSock.LineBuffer := '';
FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(POP3Host, POP3Port);
Result := FSock.LastError = 0;
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;
var
s, s1: string;
@ -184,6 +214,10 @@ begin
FTimeStamp := '<' + s1 + '>';
end;
Result := False;
if Capability then
if FAutoTLS and (Findcap('STLS') <> '') then
if StartTLS then
Capability;
if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
begin
Result := AuthApop;
@ -268,4 +302,30 @@ begin
Result := ReadResult(Value = 0) = 1;
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.

42
smtpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.002.000 |
| Project : Delphree - Synapse | 003.001.000 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -57,6 +57,8 @@ type
FEnhCode2: Integer;
FEnhCode3: Integer;
FSystemName: string;
FAutoTLS: Boolean;
FFullSSL: Boolean;
procedure EnhancedCode(const Value: string);
function ReadResult: Integer;
function AuthLogin: Boolean;
@ -76,6 +78,7 @@ type
function MailData(const Value: Tstrings): Boolean;
function Etrn(const Value: string): Boolean;
function Verify(const Value: string): Boolean;
function StartTLS: Boolean;
function EnhCodeString: string;
function FindCap(const Value: string): string;
published
@ -97,6 +100,8 @@ type
property EnhCode3: Integer read FEnhCode3;
property SystemName: string read FSystemName Write FSystemName;
property Sock: TTCPBlockSocket read FSock;
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
property FullSSL: Boolean read FFullSSL Write FFullSSL;
end;
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
@ -124,6 +129,8 @@ begin
FUsername := '';
FPassword := '';
FSystemName := FSock.LocalName;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TSMTPSend.Destroy;
@ -223,6 +230,8 @@ function TSMTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(FSMTPHost, FSMTPPort);
Result := FSock.LastError = 0;
end;
@ -272,6 +281,14 @@ begin
begin
for n := 1 to FFullResult.Count - 1 do
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
begin
s := FindCap('AUTH ');
@ -372,6 +389,20 @@ begin
Result := (x >= 250) and (x <= 259);
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;
var
s, t: string;
@ -460,6 +491,13 @@ begin
Result := False;
SMTP := TSMTPSend.Create;
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, ':');
s := SeparateRight(SMTPHost, ':');
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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -239,11 +239,10 @@ begin
begin
s := Copy(Value, x, 2);
Inc(x, 2);
if pos(#13, s) + pos(#10, s) = 0 then
Result[l] := Char(StrToIntDef('$' + s, 32))
else
Result[l] := ' ';
end;
Result[l] := Char(StrToIntDef('$' + s, 32))
end
else
break;
Inc(l);
end;
Dec(l);
@ -340,7 +339,7 @@ begin
begin
y := Pos(Value[x], Table);
if y < 1 then
y := 65;
y := 1;
d[n] := y - 1;
end;
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 |
|==============================================================================|
@ -39,7 +39,8 @@ const
DLLSSLName = 'libssl.so';
DLLUtilName = 'libcrypto.so';
{$ELSE}
DLLSSLName = 'ssleay32.dll';
DLLSSLName = 'libssl32.dll';
DLLSSLName2 = 'ssleay32.dll';
DLLUtilName = 'libeay32.dll';
{$ENDIF}
@ -57,6 +58,10 @@ const
SSL_ERROR_WANT_READ = 2;
SSL_ERROR_WANT_WRITE = 3;
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
SSLLibHandle: Integer = 0;
@ -72,7 +77,11 @@ var
SslSetFd : function(s: PSSL; fd: Integer):Integer cdecl = nil;
SslMethodV23 : function:PSSL_METHOD 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;
SslFree : procedure(ssl: PSSL) cdecl = nil;
SslAccept : function(ssl: PSSL):Integer cdecl = nil;
@ -116,6 +125,8 @@ begin
SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL));
{$ELSE}
SSLLibHandle := LoadLibrary(PChar(DLLSSLName));
if (SSLLibHandle = 0) then
SSLLibHandle := LoadLibrary(PChar(DLLSSLName2));
SSLUtilHandle := LoadLibrary(PChar(DLLUtilName));
{$ENDIF}
if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then
@ -129,7 +140,11 @@ begin
SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd'));
SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method'));
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'));
SslFree := GetProcAddress(SSLLibHandle, PChar('SSL_free'));
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 |
|==============================================================================|
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| 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. |
| All Rights Reserved. |
|==============================================================================|
@ -44,6 +44,10 @@ function TimeZone: string;
function Rfc822DateTime(t: TDateTime): string;
function CDateTime(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 GetUTTime: TDateTime;
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,
Para: 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 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;
var
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;
var
day, month, year: Word;
zone: integer;
x: integer;
s: string;
SaveSeparator: char;
n: integer;
t: TDateTime;
begin
// ddd, d mmm yyyy hh:mm:ss
// ddd, d mmm yy hh:mm:ss
// ddd, mmm d yyyy hh:mm:ss
// ddd mmm dd hh:mm:ss yyyy
// 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
// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format
// 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
// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format
Result := 0;
SaveSeparator := TimeSeparator;
try
TimeSeparator := ':';
day := 0;
month := 0;
year := 0;
zone := 0;
Value := StringReplace(Value, ' -', ' #');
Value := StringReplace(Value, '-', ' ');
Value := StringReplace(Value, ' #', ' -');
while Value <> '' do
if Value = '' then
Exit;
day := 0;
month := 0;
year := 0;
zone := 0;
Value := StringReplace(Value, ' -', ' #');
Value := StringReplace(Value, '-', ' ');
Value := StringReplace(Value, ' #', ' -');
while Value <> '' do
begin
s := Fetch(Value, ' ');
s := uppercase(s);
// timezone
if DecodetimeZone(s, x) then
begin
s := Fetch(Value, ' ');
s := uppercase(s);
// 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;
zone := x;
continue;
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;
finally
TimeSeparator := SaveSeparator;
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 := 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;
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;
{==============================================================================}
@ -836,14 +897,14 @@ end;
{==============================================================================}
function RPos(const Sub, Value: String): Integer;
function RPosEx(const Sub, Value: string; From: integer): Integer;
var
n: Integer;
l: Integer;
begin
result := 0;
l := Length(Sub);
for n := Length(Value) - l + 1 downto 1 do
for n := From - l + 1 downto 1 do
begin
if Copy(Value, n, l) = Sub then
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;
var
s: string;