pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 29

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@64 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:20:39 +00:00
parent 6f27a9fe34
commit f9140b8ecd
22 changed files with 1933 additions and 975 deletions

35
asn1util.pas

@ -3,15 +3,34 @@
|==============================================================================| |==============================================================================|
| Content: support for ASN.1 BER coding and decoding | | Content: support for ASN.1 BER coding and decoding |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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,2000,2001. |

319
blcksock.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 005.007.000 | | Project : Delphree - Synapse | 006.001.004 |
|==============================================================================| |==============================================================================|
| Content: Library base | | Content: Library base |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c)1999-2002. |
@ -22,6 +41,11 @@
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{
Special thanks to Gregor Ibic <gregor.ibic@intelicom.si>
(Intelicom d.o.o., http://www.intelicom.si)
for good inspiration about SSL programming.
}
{$Q-} {$Q-}
{$WEAKPACKAGEUNIT ON} {$WEAKPACKAGEUNIT ON}
@ -41,6 +65,9 @@ uses
const const
cLocalhost = 'localhost'; cLocalhost = 'localhost';
cAnyHost = '0.0.0.0';
cBroadcast = '255.255.255.255';
cAnyPort = '0';
type type
@ -75,12 +102,16 @@ type
FLocalSin: TSockAddrIn; FLocalSin: TSockAddrIn;
FRemoteSin: TSockAddrIn; FRemoteSin: TSockAddrIn;
FLastError: Integer; FLastError: Integer;
FLastErrorDesc: string;
FBuffer: string; FBuffer: string;
FRaiseExcept: Boolean; FRaiseExcept: Boolean;
FNonBlockMode: Boolean; FNonBlockMode: Boolean;
FMaxLineLength: Integer; FMaxLineLength: Integer;
FMaxBandwidth: Integer; FMaxSendBandwidth: Integer;
FNextSend: Cardinal; FNextSend: Cardinal;
FMaxRecvBandwidth: Integer;
FNextRecv: Cardinal;
FConvertLineEnd: Boolean;
function GetSizeRecvBuffer: Integer; function GetSizeRecvBuffer: Integer;
procedure SetSizeRecvBuffer(Size: Integer); procedure SetSizeRecvBuffer(Size: Integer);
function GetSizeSendBuffer: Integer; function GetSizeSendBuffer: Integer;
@ -95,7 +126,8 @@ type
function GetSinIP(Sin: TSockAddrIn): string; function GetSinIP(Sin: TSockAddrIn): string;
function GetSinPort(Sin: TSockAddrIn): Integer; function GetSinPort(Sin: TSockAddrIn): Integer;
procedure DoStatus(Reason: THookSocketReason; const Value: string); procedure DoStatus(Reason: THookSocketReason; const Value: string);
procedure LimitBandwidth(Length: Integer); procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: Cardinal);
procedure SetBandwidth(Value: Integer);
public public
constructor Create; constructor Create;
constructor CreateAlternate(Stub: string); constructor CreateAlternate(Stub: string);
@ -115,7 +147,7 @@ type
function RecvPacket(Timeout: Integer): string; virtual; function RecvPacket(Timeout: Integer): string; virtual;
function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual;
function PeekByte(Timeout: Integer): Byte; virtual; function PeekByte(Timeout: Integer): Byte; virtual;
function WaitingData: Integer; function WaitingData: Integer; virtual;
function WaitingDataEx: Integer; function WaitingDataEx: Integer;
procedure SetLinger(Enable: Boolean; Linger: Integer); procedure SetLinger(Enable: Boolean; Linger: Integer);
procedure GetSins; procedure GetSins;
@ -150,6 +182,7 @@ type
class function GetErrorDesc(ErrorCode: Integer): string; class function GetErrorDesc(ErrorCode: Integer): string;
property Socket: TSocket read FSocket write FSocket; property Socket: TSocket read FSocket write FSocket;
property LastError: Integer read FLastError; property LastError: Integer read FLastError;
property LastErrorDesc: string read FLastErrorDesc;
property Protocol: Integer read FProtocol; property Protocol: Integer read FProtocol;
property LineBuffer: string read FBuffer write FBuffer; property LineBuffer: string read FBuffer write FBuffer;
property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept; property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept;
@ -159,7 +192,10 @@ type
property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode; property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode;
property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
property MaxBandwidth: Integer read FMaxBandwidth Write FMaxBandwidth; property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
property MaxBandwidth: Integer Write SetBandwidth;
property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
end; end;
TSocksBlockSocket = class(TBlockSocket) TSocksBlockSocket = class(TBlockSocket)
@ -207,6 +243,9 @@ type
FSSLCertificateFile: string; FSSLCertificateFile: string;
FSSLPrivateKeyFile: string; FSSLPrivateKeyFile: string;
FSSLCertCAFile: string; FSSLCertCAFile: string;
FSSLLastError: integer;
FSSLLastErrorDesc: string;
FSSLverifyCert: Boolean;
FHTTPTunnelIP: string; FHTTPTunnelIP: string;
FHTTPTunnelPort: string; FHTTPTunnelPort: string;
FHTTPTunnel: Boolean; FHTTPTunnel: Boolean;
@ -223,6 +262,7 @@ type
destructor Destroy; override; destructor Destroy; override;
procedure CreateSocket; override; procedure CreateSocket; override;
procedure CloseSocket; override; procedure CloseSocket; override;
function WaitingData: Integer; override;
procedure Listen; procedure Listen;
function Accept: TSocket; function Accept: TSocket;
procedure Connect(IP, Port: string); override; procedure Connect(IP, Port: string); override;
@ -241,6 +281,7 @@ type
function SSLGetPeerSubjectHash: Cardinal; function SSLGetPeerSubjectHash: Cardinal;
function SSLGetPeerIssuerHash: Cardinal; function SSLGetPeerIssuerHash: Cardinal;
function SSLGetPeerFingerprint: string; function SSLGetPeerFingerprint: string;
function SSLCheck: Boolean;
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;
@ -249,6 +290,9 @@ type
property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile; property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile;
property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile; property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile;
property SSLCertCAFile: string read FSSLCertCAFile write FSSLCertCAFile; property SSLCertCAFile: string read FSSLCertCAFile write FSSLCertCAFile;
property SSLLastError: integer read FSSLLastError;
property SSLLastErrorDesc: string read FSSLLastErrorDesc;
property SSLverifyCert: Boolean read FSSLverifyCert write FSSLverifyCert;
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;
@ -299,6 +343,21 @@ type
Options: DWORD; Options: DWORD;
end; end;
TSynaClient = Class(TObject)
protected
FTargetHost: string;
FTargetPort: string;
FIPInterface: string;
FTimeout: integer;
public
constructor Create;
published
property TargetHost: string read FTargetHost Write FTargetHost;
property TargetPort: string read FTargetPort Write FTargetPort;
property IPInterface: string read FIPInterface Write FIPInterface;
property Timeout: integer read FTimeout Write FTimeout;
end;
implementation implementation
type type
@ -318,8 +377,11 @@ begin
FBuffer := ''; FBuffer := '';
FNonBlockMode := False; FNonBlockMode := False;
FMaxLineLength := 0; FMaxLineLength := 0;
FMaxBandwidth := 0; FMaxSendBandwidth := 0;
FNextSend := 0; FNextSend := 0;
FMaxRecvBandwidth := 0;
FNextRecv := 0;
FConvertLineEnd := False;
if not InitSocketInterface('') then if not InitSocketInterface('') then
begin begin
e := ESynapseError.Create('Error loading Winsock DLL!'); e := ESynapseError.Create('Error loading Winsock DLL!');
@ -378,7 +440,7 @@ begin
Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) Sin.sin_port := synsock.htons(StrToIntDef(Port, 0))
else else
Sin.sin_port := ServEnt^.s_port; Sin.sin_port := ServEnt^.s_port;
if IP = '255.255.255.255' then if IP = cBroadcast then
Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST)
else else
begin begin
@ -472,27 +534,33 @@ begin
synsock.GetPeerName(FSocket, FremoteSin, Len); synsock.GetPeerName(FSocket, FremoteSin, Len);
end; end;
procedure TBlockSocket.LimitBandwidth(Length: Integer); procedure TBlockSocket.SetBandwidth(Value: Integer);
begin
MaxSendBandwidth := Value;
MaxRecvBandwidth := Value;
end;
procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: Cardinal);
var var
x: Cardinal; x: Cardinal;
y: integer; y: Cardinal;
begin begin
if FMaxBandwidth > 0 then if MaxB > 0 then
begin begin
y:= GetTick; y := GetTick;
if FNextSend > y then if Next > y then
begin begin
x:= FNextSend - y; x := Next - y;
if x > 0 then if x > 0 then
sleep(x); sleep(x);
end; end;
FNextSend:= y + Trunc((Length / FMaxBandwidth) * 1000); Next := y + Trunc((Length / MaxB) * 1000);
end; end;
end; end;
function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer;
begin begin
LimitBandwidth(Length); LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
Result := synsock.Send(FSocket, Buffer^, Length, 0); Result := synsock.Send(FSocket, Buffer^, Length, 0);
SockCheck(Result); SockCheck(Result);
ExceptCheck; ExceptCheck;
@ -511,6 +579,7 @@ end;
function TBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; function TBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer;
begin begin
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
Result := synsock.Recv(FSocket, Buffer^, Length, 0); Result := synsock.Recv(FSocket, Buffer^, Length, 0);
if Result = 0 then if Result = 0 then
FLastError := WSAECONNRESET FLastError := WSAECONNRESET
@ -602,7 +671,8 @@ begin
begin begin
SetLength(Result, x); SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x); x := RecvBuffer(Pointer(Result), x);
SetLength(Result, x); if x >= 0 then
SetLength(Result, x);
end; end;
end end
else else
@ -634,31 +704,57 @@ var
x: Integer; x: Integer;
s: string; s: string;
l: Integer; l: Integer;
CorCRLF: Boolean;
t: string;
tl: integer;
begin begin
FLastError := 0; FLastError := 0;
Result := ''; Result := '';
l := system.Length(Terminator); l := system.Length(Terminator);
if l = 0 then if l = 0 then
Exit; Exit;
tl := l;
CorCRLF := FConvertLineEnd and (Terminator = #$0d + #$0a);
// if FBuffer contains requested data, return it... // if FBuffer contains requested data, return it...
if FBuffer<>'' then if FBuffer<>'' then
begin begin
x := pos(Terminator, FBuffer); if CorCRLF then
begin
t := '';
x := PosCRLF(FBuffer, t);
tl := system.Length(t);
end
else
begin
x := pos(Terminator, FBuffer);
tl := l;
end;
if x > 0 then if x > 0 then
begin begin
Result := copy(FBuffer, 1, x - 1); Result := copy(FBuffer, 1, x - 1);
System.Delete(FBuffer, 1, x + l - 1); System.Delete(FBuffer, 1, x + tl - 1);
exit; Exit;
end; end;
end; end;
// now FBuffer is empty or not contains all data... // now FBuffer is empty or not contains all data...
s := ''; s := '';
x := 0; x := 0;
repeat repeat
//get rest of FBuffer or incomming new data...
s := s + RecvPacket(Timeout); s := s + RecvPacket(Timeout);
if FLastError <> 0 then if FLastError <> 0 then
Break; Break;
x := Pos(Terminator, s); if CorCRLF then
begin
t := '';
x := PosCRLF(s, t);
tl := system.Length(t);
end
else
begin
x := pos(Terminator, s);
tl := l;
end;
if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
begin begin
FLastError := WSAENOBUFS; FLastError := WSAENOBUFS;
@ -668,7 +764,7 @@ begin
if x > 0 then if x > 0 then
begin begin
Result := Copy(s, 1, x - 1); Result := Copy(s, 1, x - 1);
System.Delete(s, 1, x + l - 1); System.Delete(s, 1, x + tl - 1);
end; end;
FBuffer := s; FBuffer := s;
ExceptCheck; ExceptCheck;
@ -710,8 +806,12 @@ end;
function TBlockSocket.SockCheck(SockResult: Integer): Integer; function TBlockSocket.SockCheck(SockResult: Integer): Integer;
begin begin
if SockResult = SOCKET_ERROR then FLastErrorDesc := '';
Result := synsock.WSAGetLastError if SockResult = integer(SOCKET_ERROR) then
begin
Result := synsock.WSAGetLastError;
FLastErrorDesc := GetErrorDesc(Result);
end
else else
Result := 0; Result := 0;
FLastError := Result; FLastError := Result;
@ -931,7 +1031,7 @@ function TBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer;
var var
Len: Integer; Len: Integer;
begin begin
LimitBandwidth(Length); LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
Len := SizeOf(FRemoteSin); Len := SizeOf(FRemoteSin);
Result := synsock.SendTo(FSocket, Buffer^, Length, 0, FRemoteSin, Len); Result := synsock.SendTo(FSocket, Buffer^, Length, 0, FRemoteSin, Len);
SockCheck(Result); SockCheck(Result);
@ -943,6 +1043,7 @@ function TBlockSocket.RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer;
var var
Len: Integer; Len: Integer;
begin begin
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
Len := SizeOf(FRemoteSin); Len := SizeOf(FRemoteSin);
Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, FRemoteSin, Len); Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, FRemoteSin, Len);
SockCheck(Result); SockCheck(Result);
@ -1256,7 +1357,6 @@ function TSocksBlockSocket.SocksRequest(Cmd: Byte;
var var
Buf: string; Buf: string;
begin begin
Result := False;
FBypassFlag := True; FBypassFlag := True;
try try
Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port); Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port);
@ -1330,9 +1430,9 @@ begin
y := Ord(Value[5]); y := Ord(Value[5]);
if Length(Value) < (5 + y + 2) then if Length(Value) < (5 + y + 2) then
Exit; Exit;
for n := 6 to 6 + y do for n := 6 to 6 + y - 1 do
FSocksResponseIP := FSocksResponseIP + Value[n]; FSocksResponseIP := FSocksResponseIP + Value[n];
Result := 5 + y +1; Result := 5 + y + 1;
end; end;
else else
Exit; Exit;
@ -1498,11 +1598,10 @@ begin
Password := ''; Password := '';
if TTCPBlockSocket(userdata) is TTCPBlockSocket then if TTCPBlockSocket(userdata) is TTCPBlockSocket then
Password := TTCPBlockSocket(userdata).SSLPassword; Password := TTCPBlockSocket(userdata).SSLPassword;
FillChar(buf, Size, 0);
if Length(Password) > (Size - 1) then if Length(Password) > (Size - 1) then
SetLength(Password, Size - 1); SetLength(Password, Size - 1);
StrPCopy(buf, Password);
Result := Length(Password); Result := Length(Password);
StrLCopy(buf, PChar(Password + #0), Result + 1);
end; end;
constructor TTCPBlockSocket.Create; constructor TTCPBlockSocket.Create;
@ -1516,6 +1615,9 @@ begin
FSSLPassword := ''; FSSLPassword := '';
FSsl := nil; FSsl := nil;
Fctx := nil; Fctx := nil;
FSSLLastError := 0;
FSSLLastErrorDesc := '';
FSSLverifyCert := False;
FHTTPTunnelIP := ''; FHTTPTunnelIP := '';
FHTTPTunnelPort := ''; FHTTPTunnelPort := '';
FHTTPTunnel := False; FHTTPTunnel := False;
@ -1545,6 +1647,15 @@ begin
inherited CloseSocket; inherited CloseSocket;
end; end;
function TTCPBlockSocket.WaitingData: Integer;
begin
Result := 0;
if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then
Result := sslpending(Fssl);
if Result = 0 then
Result := inherited WaitingData;
end;
procedure TTCPBlockSocket.Listen; procedure TTCPBlockSocket.Listen;
var var
b: Boolean; b: Boolean;
@ -1677,10 +1788,14 @@ begin
FLastError := 0; FLastError := 0;
if not FSSLEnabled then if not FSSLEnabled then
SSLEnabled := True; SSLEnabled := True;
if sslsetfd(FSsl, FSocket) < 0 then
FLastError := WSASYSNOTREADY;
if (FLastError = 0) then if (FLastError = 0) then
if sslconnect(FSsl) < 0 then if sslsetfd(FSsl, FSocket) < 1 then
begin
FLastError := WSASYSNOTREADY;
SSLCheck;
end;
if (FLastError = 0) then
if sslconnect(FSsl) < 1 then
FLastError := WSASYSNOTREADY; FLastError := WSASYSNOTREADY;
ExceptCheck; ExceptCheck;
end; end;
@ -1732,46 +1847,114 @@ begin
Result := inherited GetRemoteSinPort; Result := inherited GetRemoteSinPort;
end; end;
function TTCPBlockSocket.SSLCheck: Boolean;
var
ErrBuf: array[0..255] of Char;
begin
Result := true;
FSSLLastErrorDesc := '';
FSSLLastError := ErrGetError;
ErrClearError;
if FSSLLastError <> 0 then
begin
Result := False;
ErrErrorString(FSSLLastError, ErrBuf);
FSSLLastErrorDesc := ErrBuf;
end;
end;
function TTCPBlockSocket.SetSslKeys: boolean; function TTCPBlockSocket.SetSslKeys: boolean;
begin 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; Result := True;
if FSSLCertificateFile <> '' then
if SslCtxUseCertificateChainFile(FCtx, PChar(FSSLCertificateFile)) <> 1 then
begin
Result := False;
SSLCheck;
Exit;
end;
if FSSLPrivateKeyFile <> '' then
if SslCtxUsePrivateKeyFile(FCtx, PChar(FSSLPrivateKeyFile), 1) <> 1 then
begin
Result := False;
SSLCheck;
Exit;
end;
if FSSLCertCAFile <> '' then
if SslCtxLoadVerifyLocations(FCtx, PChar(FSSLCertCAFile), nil) <> 1 then
begin
Result := False;
SSLCheck;
end;
end; end;
procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean); procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean);
var
err: Boolean;
begin begin
FLastError := 0;
if Value <> FSslEnabled then if Value <> FSslEnabled then
if Value then if Value then
begin begin
FBuffer := '';
FSSLLastErrorDesc := '';
FSSLLastError := 0;
if InitSSLInterface then if InitSSLInterface then
begin begin
SslLibraryInit; SslLibraryInit;
SslLoadErrorStrings; SslLoadErrorStrings;
err := False;
Fctx := nil; Fctx := nil;
Fctx := SslCtxNew(SslMethodV23); Fctx := SslCtxNew(SslMethodV23);
SslCtxSetCipherList(Fctx, PChar(FSSLCiphers)); if Fctx = nil then
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); begin
SslCtxSetDefaultPasswdCbUserdata(FCtx, self); SSLCheck;
SetSSLKeys; FlastError := WSAEPROTONOSUPPORT;
Fssl := nil; err := True;
Fssl := SslNew(Fctx); end
FSslEnabled := True; else
begin
SslCtxSetCipherList(Fctx, PChar(FSSLCiphers));
if FSSLverifyCert then
SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil)
else
SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil);
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
if not SetSSLKeys then
FLastError := WSAEINVAL
else
begin
Fssl := nil;
Fssl := SslNew(Fctx);
if Fssl = nil then
begin
SSLCheck;
FlastError := WSAEPROTONOSUPPORT;
err := True;
end;
end;
end;
if err then
DestroySSLInterface
else
FSslEnabled := True;
end end
else DestroySSLInterface; else
begin
DestroySSLInterface;
FlastError := WSAEPROTONOSUPPORT;
end;
end end
else else
begin begin
FBuffer := '';
sslfree(Fssl); sslfree(Fssl);
SslCtxFree(Fctx); SslCtxFree(Fctx);
DestroySSLInterface; DestroySSLInterface;
FSslEnabled := False; FSslEnabled := False;
end; end;
ExceptCheck;
end; end;
function TTCPBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; function TTCPBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer;
@ -1784,7 +1967,7 @@ begin
repeat repeat
Result := SslRead(FSsl, Buffer, Length); Result := SslRead(FSsl, Buffer, Length);
err := SslGetError(FSsl, Result); err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) or (err <> SSL_ERROR_WANT_WRITE); until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then if err = SSL_ERROR_ZERO_RETURN then
Result := 0 Result := 0
else else
@ -1807,7 +1990,7 @@ begin
repeat repeat
Result := SslWrite(FSsl, Buffer, Length); Result := SslWrite(FSsl, Buffer, Length);
err := SslGetError(FSsl, Result); err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) or (err <> SSL_ERROR_WANT_WRITE); until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then if err = SSL_ERROR_ZERO_RETURN then
Result := 0 Result := 0
else else
@ -1822,14 +2005,17 @@ end;
function TTCPBlockSocket.SSLAcceptConnection: Boolean; function TTCPBlockSocket.SSLAcceptConnection: Boolean;
begin begin
Result := False;
FLastError := 0; FLastError := 0;
if not FSSLEnabled then if not FSSLEnabled then
SSLEnabled := True; SSLEnabled := True;
if sslsetfd(FSsl, FSocket) < 0 then
FLastError := WSASYSNOTREADY;
if (FLastError = 0) then if (FLastError = 0) then
if sslAccept(FSsl) < 0 then if sslsetfd(FSsl, FSocket) < 1 then
begin
FLastError := WSASYSNOTREADY;
SSLCheck;
end;
if (FLastError = 0) then
if sslAccept(FSsl) < 1 then
FLastError := WSASYSNOTREADY; FLastError := WSASYSNOTREADY;
ExceptCheck; ExceptCheck;
Result := FLastError = 0; Result := FLastError = 0;
@ -1914,4 +2100,15 @@ begin
inherited CreateSocket; inherited CreateSocket;
end; end;
{======================================================================}
constructor TSynaClient.Create;
begin
inherited Create;
FIPInterface := cAnyHost;
FTargetHost := cLocalhost;
FTargetPort := cAnyPort;
FTimeout := 5000;
end;
end. end.

50
dnssend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.001.004 | | Project : Delphree - Synapse | 001.002.000 |
|==============================================================================| |==============================================================================|
| Content: DNS client | | Content: DNS client |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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,2001. |
@ -81,10 +100,8 @@ const
QTYPE_ALL = 255; // QTYPE_ALL = 255; //
type type
TDNSSend = class(TObject) TDNSSend = class(TSynaClient)
private private
FTimeout: Integer;
FDNSHost: string;
FRCode: Integer; FRCode: Integer;
FBuffer: string; FBuffer: string;
FSock: TUDPBlockSocket; FSock: TUDPBlockSocket;
@ -100,8 +117,6 @@ type
function DNSQuery(Name: string; QType: Integer; function DNSQuery(Name: string; QType: Integer;
const Reply: TStrings): Boolean; const Reply: TStrings): Boolean;
published published
property Timeout: Integer read FTimeout Write FTimeout;
property DNSHost: string read FDNSHost Write FDNSHost;
property RCode: Integer read FRCode; property RCode: Integer read FRCode;
property Sock: TUDPBlockSocket read FSock; property Sock: TUDPBlockSocket read FSock;
end; end;
@ -117,7 +132,7 @@ begin
FSock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
FSock.CreateSocket; FSock.CreateSocket;
FTimeout := 5000; FTimeout := 5000;
FDNSHost := cLocalhost; FTargetPort := cDnsProtocol;
end; end;
destructor TDNSSend.Destroy; destructor TDNSSend.Destroy;
@ -290,7 +305,8 @@ begin
if IsIP(Name) then if IsIP(Name) then
Name := ReverseIP(Name) + '.in-addr.arpa'; Name := ReverseIP(Name) + '.in-addr.arpa';
FBuffer := CodeHeader + CodeQuery(Name, QType); FBuffer := CodeHeader + CodeQuery(Name, QType);
FSock.Connect(FDNSHost, cDnsProtocol); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FBuffer); FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout); FBuffer := FSock.RecvPacket(FTimeout);
if (FSock.LastError = 0) and (Length(FBuffer) > 13) then if (FSock.LastError = 0) and (Length(FBuffer) > 13) then
@ -337,7 +353,7 @@ begin
t := TStringList.Create; t := TStringList.Create;
DNS := TDNSSend.Create; DNS := TDNSSend.Create;
try try
DNS.DNSHost := DNSHost; DNS.TargetHost := DNSHost;
if DNS.DNSQuery(Domain, QType_MX, t) then if DNS.DNSQuery(Domain, QType_MX, t) then
begin begin
{ normalize preference number to 5 digits } { normalize preference number to 5 digits }

240
ftpsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.000.000 | | Project : Delphree - Synapse | 002.003.001 |
|==============================================================================| |==============================================================================|
| Content: FTP client | | Content: FTP client |
|==============================================================================| |==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
@ -68,14 +87,11 @@ type
property List: TList read FList; property List: TList read FList;
end; end;
TFTPSend = class(TObject) TFTPSend = class(TSynaClient)
private private
FOnStatus: TFTPStatus; FOnStatus: TFTPStatus;
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FDSock: TTCPBlockSocket; FDSock: TTCPBlockSocket;
FTimeout: Integer;
FFTPHost: string;
FFTPPort: string;
FResultCode: Integer; FResultCode: Integer;
FResultString: string; FResultString: string;
FFullResult: TStringList; FFullResult: TStringList;
@ -114,6 +130,7 @@ type
function FTPCommand(const Value: string): integer; function FTPCommand(const Value: string): integer;
function Login: Boolean; function Login: Boolean;
procedure Logout; procedure Logout;
procedure Abort;
function List(Directory: string; NameList: Boolean): Boolean; function List(Directory: string; NameList: Boolean): Boolean;
function RetriveFile(const FileName: string; Restore: Boolean): Boolean; function RetriveFile(const FileName: string; Restore: Boolean): Boolean;
function StoreFile(const FileName: string; Restore: Boolean): Boolean; function StoreFile(const FileName: string; Restore: Boolean): Boolean;
@ -129,9 +146,6 @@ type
function CreateDir(const Directory: string): Boolean; function CreateDir(const Directory: string): Boolean;
function GetCurrentDir: String; function GetCurrentDir: String;
published published
property Timeout: Integer read FTimeout Write FTimeout;
property FTPHost: string read FFTPHost Write FFTPHost;
property FTPPort: string read FFTPPort Write FFTPPort;
property ResultCode: Integer read FResultCode; property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString; property ResultString: string read FResultString;
property FullResult: TStringList read FFullResult; property FullResult: TStringList read FFullResult;
@ -179,8 +193,7 @@ begin
FDSock := TTCPBlockSocket.Create; FDSock := TTCPBlockSocket.Create;
FFtpList := TFTPList.Create; FFtpList := TFTPList.Create;
FTimeout := 300000; FTimeout := 300000;
FFTPHost := cLocalhost; FTargetPort := cFtpProtocol;
FFTPPort := cFtpProtocol;
FUsername := 'anonymous'; FUsername := 'anonymous';
FPassword := 'anonymous@' + FSock.LocalName; FPassword := 'anonymous@' + FSock.LocalName;
FDirectFile := False; FDirectFile := False;
@ -285,10 +298,10 @@ begin
Result := False; Result := False;
if FFWHost = '' then if FFWHost = '' then
Mode := 0; Mode := 0;
if (FFTPPort = cFtpProtocol) or (FFTPPort = '21') then if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then
FTPServer := FFTPHost FTPServer := FTargetHost
else else
FTPServer := FFTPHost + ':' + FFTPPort; FTPServer := FTargetHost + ':' + FTargetPort;
case Mode of case Mode of
-1: -1:
LogonActions := CustomLogon; LogonActions := CustomLogon;
@ -349,8 +362,9 @@ function TFTPSend.Connect: Boolean;
begin begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.CreateSocket; FSock.CreateSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FFWHost = '' then if FFWHost = '' then
FSock.Connect(FFTPHost, FFTPPort) FSock.Connect(FTargetHost, FTargetPort)
else else
FSock.Connect(FFWHost, FFWPort); FSock.Connect(FFWHost, FFWPort);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
@ -362,7 +376,7 @@ begin
FCanResume := False; FCanResume := False;
if not Connect then if not Connect then
Exit; Exit;
if ReadResult <> 220 then if (ReadResult div 100) <> 2 then
Exit; Exit;
if not Auth(FFWMode) then if not Auth(FFWMode) then
Exit; Exit;
@ -420,11 +434,12 @@ begin
Result := False; Result := False;
if FPassiveMode then if FPassiveMode then
begin begin
if FTPCommand('PASV') <> 227 then if (FTPCommand('PASV') div 100) <> 2 then
Exit; Exit;
ParseRemote(FResultString); ParseRemote(FResultString);
FDSock.CloseSocket; FDSock.CloseSocket;
FDSock.CreateSocket; FDSock.CreateSocket;
FSock.Bind(FIPInterface, cAnyPort);
FDSock.Connect(FDataIP, FDataPort); FDSock.Connect(FDataIP, FDataPort);
Result := FDSock.LastError = 0; Result := FDSock.LastError = 0;
end end
@ -436,7 +451,11 @@ begin
s := cFtpDataProtocol s := cFtpDataProtocol
else else
s := '0'; s := '0';
FDSock.Bind(FDSock.LocalName, s); //IP cannot be '0.0.0.0'!
if FIPInterface = cAnyHost then
FDSock.Bind(FDSock.LocalName, s)
else
FSock.Bind(FIPInterface, s);
if FDSock.LastError <> 0 then if FDSock.LastError <> 0 then
Exit; Exit;
FDSock.Listen; FDSock.Listen;
@ -447,7 +466,7 @@ begin
s := StringReplace(FDataIP, '.', ','); s := StringReplace(FDataIP, '.', ',');
s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256) s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256)
+ ',' + IntToStr(FDSock.GetLocalSinPort mod 256); + ',' + IntToStr(FDSock.GetLocalSinPort mod 256);
Result := FTPCommand(s) = 200; Result := (FTPCommand(s) div 100) = 2;
end; end;
end; end;
@ -485,9 +504,9 @@ begin
if FDSock.LastError = 0 then if FDSock.LastError = 0 then
DestStream.Write(Pointer(buf)^, Length(buf)); DestStream.Write(Pointer(buf)^, Length(buf));
until FDSock.LastError <> 0; until FDSock.LastError <> 0;
FDSock.CloseSocket;
x := ReadResult; x := ReadResult;
if (x = 226) or (x = 250) then Result := (x div 100) = 2;
Result := True;
finally finally
FDSock.CloseSocket; FDSock.CloseSocket;
end; end;
@ -524,8 +543,7 @@ begin
Exit; Exit;
FDSock.CloseSocket; FDSock.CloseSocket;
x := ReadResult; x := ReadResult;
if (x = 226) or (x = 250) then Result := (x div 100) = 2;
Result := True;
finally finally
FDSock.CloseSocket; FDSock.CloseSocket;
end; end;
@ -577,7 +595,7 @@ begin
if FDirectFile then if FDirectFile then
if Restore and FileExists(FDirectFileName) then if Restore and FileExists(FDirectFileName) then
RetrStream := TFileStream.Create(FDirectFileName, RetrStream := TFileStream.Create(FDirectFileName,
fmOpenReadWrite or fmShareExclusive) fmOpenReadWrite or fmShareExclusive)
else else
RetrStream := TFileStream.Create(FDirectFileName, RetrStream := TFileStream.Create(FDirectFileName,
fmCreate or fmShareDenyWrite) fmCreate or fmShareDenyWrite)
@ -590,7 +608,7 @@ begin
if Restore then if Restore then
begin begin
RetrStream.Seek(0, soFromEnd); RetrStream.Seek(0, soFromEnd);
if FTPCommand('REST ' + IntToStr(RetrStream.Size)) <> 350 then if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then
Exit; Exit;
end end
else else
@ -637,7 +655,7 @@ begin
RestoreAt := 0; RestoreAt := 0;
FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt)); FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt));
if FCanResume then if FCanResume then
if FTPCommand('REST ' + IntToStr(RestoreAt)) <> 350 then if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then
Exit; Exit;
SendStream.Seek(RestoreAt, soFromBeginning); SendStream.Seek(RestoreAt, soFromBeginning);
if (FTPCommand(Command) div 100) <> 1 then if (FTPCommand(Command) div 100) <> 1 then
@ -688,14 +706,14 @@ end;
function TFTPSend.RenameFile(const OldName, NewName: string): Boolean; function TFTPSend.RenameFile(const OldName, NewName: string): Boolean;
begin begin
Result := False; Result := False;
if FTPCommand('RNFR ' + OldName) <> 350 then if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then
Exit; Exit;
Result := FTPCommand('RNTO ' + NewName) = 250; Result := (FTPCommand('RNTO ' + NewName) div 100) = 2;
end; end;
function TFTPSend.DeleteFile(const FileName: string): Boolean; function TFTPSend.DeleteFile(const FileName: string): Boolean;
begin begin
Result := FTPCommand('DELE ' + FileName) = 250; Result := (FTPCommand('DELE ' + FileName) div 100) = 2;
end; end;
function TFTPSend.FileSize(const FileName: string): integer; function TFTPSend.FileSize(const FileName: string): integer;
@ -703,7 +721,7 @@ var
s: string; s: string;
begin begin
Result := -1; Result := -1;
if FTPCommand('SIZE ' + FileName) = 213 then if (FTPCommand('SIZE ' + FileName) div 100) = 2 then
begin begin
s := SeparateRight(ResultString, ' '); s := SeparateRight(ResultString, ' ');
s := SeparateLeft(s, ' '); s := SeparateLeft(s, ' ');
@ -713,28 +731,28 @@ end;
function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean; function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean;
begin begin
Result := FTPCommand('CWD ' + Directory) = 250; Result := (FTPCommand('CWD ' + Directory) div 100) = 2;
end; end;
function TFTPSend.ChangeToRootDir: Boolean; function TFTPSend.ChangeToRootDir: Boolean;
begin begin
Result := FTPCommand('CDUP') = 200; Result := (FTPCommand('CDUP') div 100) = 2;
end; end;
function TFTPSend.DeleteDir(const Directory: string): Boolean; function TFTPSend.DeleteDir(const Directory: string): Boolean;
begin begin
Result := FTPCommand('RMD ' + Directory) = 250; Result := (FTPCommand('RMD ' + Directory) div 100) = 2;
end; end;
function TFTPSend.CreateDir(const Directory: string): Boolean; function TFTPSend.CreateDir(const Directory: string): Boolean;
begin begin
Result := FTPCommand('MKD ' + Directory) = 257; Result := (FTPCommand('MKD ' + Directory) div 100) = 2;
end; end;
function TFTPSend.GetCurrentDir: String; function TFTPSend.GetCurrentDir: String;
begin begin
Result := ''; Result := '';
if FTPCommand('PWD') = 257 then if (FTPCommand('PWD') div 100) = 2 then
begin begin
Result := SeparateRight(FResultString, '"'); Result := SeparateRight(FResultString, '"');
Result := Separateleft(Result, '"'); Result := Separateleft(Result, '"');
@ -767,6 +785,7 @@ begin
end; end;
// based on idea by D. J. Bernstein, djb@pobox.com // based on idea by D. J. Bernstein, djb@pobox.com
// fixed UNIX style decoding by Alex, akudrin@rosbi.ru
function TFTPList.ParseLine(Value: string): Boolean; function TFTPList.ParseLine(Value: string): Boolean;
var var
flr: TFTPListRec; flr: TFTPListRec;
@ -777,10 +796,12 @@ var
mday: Word; mday: Word;
t: TDateTime; t: TDateTime;
x: integer; x: integer;
al_tmp : array[1..2] of string; // alex
begin begin
Result := False; Result := False;
if Length(Value) < 2 then if Length(Value) < 2 then
Exit; Exit;
year := 0; year := 0;
month := 0; month := 0;
mday := 0; mday := 0;
@ -853,68 +874,69 @@ begin
(Value[1] = 's') or (Value[1] = 's') or
(Value[1] = '-') then (Value[1] = '-') then
begin begin
if Value[1] = 'd' then
flr.Directory := True; // alex begin
if Value[1] = '-' then // default year
flr.Readable := True; DecodeDate(date,year,month,mday); // alex
if Value[1] = 'l' then month:=0;
mday :=0;
if Value[1] = 'd' then flr.Directory := True
else if Value[1] = '-' then flr.Readable := True
else if Value[1] = 'l' then
begin begin
flr.Directory := True; flr.Directory := True;
flr.Readable := True; flr.Readable := True;
end; end;
state := 1;
state:=1;
s := Fetch(Value, ' '); s := Fetch(Value, ' ');
while s <> '' do while s<>'' do
begin begin
case state of month:=GetMonthNumber(s);
1: if month>0 then
begin break;
state := 2; al_tmp[state]:=s;
if (s[1] = 'f') and (Pos(' ', s) = 6) then if state=1 then state:=2
state := 3; else state:=1;
end; s := Fetch(Value, ' ');
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; end;
Exit; if month>0 then begin
if state=1 then
flr.FileSize := StrToIntDef(al_tmp[2], 0)
else flr.FileSize := StrToIntDef(al_tmp[1], 0);
state:=1;
s := Fetch(Value, ' ');
while s <> '' do
begin
case state of
1 : mday := StrToIntDef(s, 0);
2 : 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);
end;
3 : begin
if Value <> '' then
s := s + ' ' + Value;
s := SeparateLeft(s, ' -> ');
flr.FileName := s;
Result := True;
break;
end;
end;
inc(state);
s := Fetch(Value, ' ');
end;
end;
// alex end
exit;
end; end;
{Microsoft NT 4.0 FTP Service {Microsoft NT 4.0 FTP Service
10-20-98 08:57AM 619098 rizrem.zip 10-20-98 08:57AM 619098 rizrem.zip
@ -947,8 +969,7 @@ begin
end; end;
if Value = '' then if Value = '' then
Exit; Exit;
s := Fetch(Value, ' '); flr.FileName := Trim(s);
flr.FileName := s;
Result := True; Result := True;
Exit; Exit;
end; end;
@ -1015,8 +1036,8 @@ begin
Username := User; Username := User;
Password := Pass; Password := Pass;
end; end;
FTPHost := IP; TargetHost := IP;
FTPPort := Port; TargetPort := Port;
if not Login then if not Login then
Exit; Exit;
DirectFileName := LocalFile; DirectFileName := LocalFile;
@ -1039,8 +1060,8 @@ begin
Username := User; Username := User;
Password := Pass; Password := Pass;
end; end;
FTPHost := IP; TargetHost := IP;
FTPPort := Port; TargetPort := Port;
if not Login then if not Login then
Exit; Exit;
DirectFileName := LocalFile; DirectFileName := LocalFile;
@ -1074,10 +1095,10 @@ begin
ToFTP.Username := ToUser; ToFTP.Username := ToUser;
ToFTP.Password := ToPass; ToFTP.Password := ToPass;
end; end;
FromFTP.FTPHost := FromIP; FromFTP.TargetHost := FromIP;
FromFTP.FTPPort := FromPort; FromFTP.TargetPort := FromPort;
ToFTP.FTPHost := ToIP; ToFTP.TargetHost := ToIP;
ToFTP.FTPPort := ToPort; ToFTP.TargetPort := ToPort;
if not FromFTP.Login then if not FromFTP.Login then
Exit; Exit;
if not ToFTP.Login then if not ToFTP.Login then
@ -1111,4 +1132,9 @@ begin
end; end;
end; end;
procedure TFTPSend.Abort;
begin
FDSock.CloseSocket;
end;
end. end.

84
httpsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 003.000.003 | | Project : Delphree - Synapse | 003.002.000 |
|==============================================================================| |==============================================================================|
| Content: HTTP client | | Content: HTTP client |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
@ -39,7 +58,7 @@ const
type type
TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED); TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
THTTPSend = class(TObject) THTTPSend = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FTransferEncoding: TTransferEncoding; FTransferEncoding: TTransferEncoding;
@ -50,9 +69,6 @@ type
FMimeType: string; FMimeType: string;
FProtocol: string; FProtocol: string;
FKeepAlive: Boolean; FKeepAlive: Boolean;
FTimeout: Integer;
FHTTPHost: string;
FHTTPPort: string;
FProxyHost: string; FProxyHost: string;
FProxyPort: string; FProxyPort: string;
FProxyUser: string; FProxyUser: string;
@ -74,9 +90,6 @@ type
property MimeType: string read FMimeType Write FMimeType; property MimeType: string read FMimeType Write FMimeType;
property Protocol: string read FProtocol Write FProtocol; property Protocol: string read FProtocol Write FProtocol;
property KeepAlive: Boolean read FKeepAlive Write FKeepAlive; property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
property Timeout: Integer read FTimeout Write FTimeout;
property HTTPHost: string read FHTTPHost;
property HTTPPort: string read FHTTPPort;
property ProxyHost: string read FProxyHost Write FProxyHost; property ProxyHost: string read FProxyHost Write FProxyHost;
property ProxyPort: string read FProxyPort Write FProxyPort; property ProxyPort: string read FProxyPort Write FProxyPort;
property ProxyUser: string read FProxyUser Write FProxyUser; property ProxyUser: string read FProxyUser Write FProxyUser;
@ -91,7 +104,7 @@ function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
function HttpPostBinary(const URL: string; const Data: TStream): Boolean; function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean; function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
function HttpPostFile(const URL, FieldName, FileName: string; function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStringList): Boolean; const Data: TStream; const ResultData: TStrings): Boolean;
implementation implementation
@ -106,9 +119,9 @@ begin
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.SizeRecvBuffer := 65536; FSock.SizeRecvBuffer := 65536;
FSock.SizeSendBuffer := 65536; FSock.SizeSendBuffer := 65536;
FSock.ConvertLineEnd := True;
FTimeout := 300000; FTimeout := 300000;
FHTTPHost := cLocalhost; FTargetPort := cHttpProtocol;
FHTTPPort := cHttpProtocol;
FProxyHost := ''; FProxyHost := '';
FProxyPort := '8080'; FProxyPort := '8080';
FProxyUser := ''; FProxyUser := '';
@ -155,7 +168,6 @@ var
ToClose: Boolean; ToClose: Boolean;
Size: Integer; Size: Integer;
Prot, User, Pass, Host, Port, Path, Para, URI: string; Prot, User, Pass, Host, Port, Path, Para, URI: string;
n: Integer;
s, su: string; s, su: string;
HttpTunnel: Boolean; HttpTunnel: Boolean;
begin begin
@ -219,27 +231,30 @@ begin
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol); FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
if (FProxyHost <> '') and not(HttpTunnel) then if (FProxyHost <> '') and not(HttpTunnel) then
begin begin
FHTTPHost := FProxyHost; FTargetHost := FProxyHost;
FHTTPPort := FProxyPort; FTargetPort := FProxyPort;
end end
else else
begin begin
FHTTPHost := Host; FTargetHost := Host;
FHTTPPort := Port; FTargetPort := Port;
end; end;
if FHeaders[FHeaders.Count - 1] <> '' then if FHeaders[FHeaders.Count - 1] <> '' then
FHeaders.Add(''); FHeaders.Add('');
{ connect } { connect }
if (FAliveHost <> FHTTPHost) or (FAlivePort <> FHTTPPort) then if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort) then
begin begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.CreateSocket; FSock.CreateSocket;
FSock.Connect(FHTTPHost, FHTTPPort); FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Exit; Exit;
FAliveHost := FHTTPHost; FSock.Connect(FTargetHost, FTargetPort);
FAlivePort := FHTTPPort; if FSock.LastError <> 0 then
Exit;
FAliveHost := FTargetHost;
FAlivePort := FTargetPort;
end end
else else
begin begin
@ -247,7 +262,10 @@ begin
begin begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.CreateSocket; FSock.CreateSocket;
FSock.Connect(FHTTPHost, FHTTPPort); FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError <> 0 then
Exit;
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Exit; Exit;
end; end;
@ -257,7 +275,11 @@ begin
if FProtocol = '0.9' then if FProtocol = '0.9' then
FSock.SendString(FHeaders[0] + CRLF) FSock.SendString(FHeaders[0] + CRLF)
else else
{$IFDEF LINUX}
FSock.SendString(AdjustLineBreaks(FHeaders.Text, tlbsCRLF));
{$ELSE}
FSock.SendString(FHeaders.Text); FSock.SendString(FHeaders.Text);
{$ENDIF}
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Exit; Exit;
@ -320,7 +342,7 @@ begin
else else
FHeaders.Add(Status100Error); FHeaders.Add(Status100Error);
{ if need receive hedaers, receive and parse it } { if need receive headers, receive and parse it }
ToClose := FProtocol <> '1.1'; ToClose := FProtocol <> '1.1';
if FHeaders.Count > 0 then if FHeaders.Count > 0 then
repeat repeat
@ -479,7 +501,7 @@ begin
end; end;
function HttpPostFile(const URL, FieldName, FileName: string; function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStringList): Boolean; const Data: TStream; const ResultData: TStrings): Boolean;
const const
CRLF = #$0D + #$0A; CRLF = #$0D + #$0A;
var var

54
imapsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.000.000 | | Project : Delphree - Synapse | 002.001.000 |
|==============================================================================| |==============================================================================|
| Content: IMAP4rev1 client | | Content: IMAP4rev1 client |
|==============================================================================| |==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c)2001-2002. |
@ -40,12 +59,9 @@ const
cIMAPProtocol = '143'; cIMAPProtocol = '143';
type type
TIMAPSend = class(TObject) TIMAPSend = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FTimeout: Integer;
FIMAPHost: string;
FIMAPPort: string;
FTagCommand: integer; FTagCommand: integer;
FResultString: string; FResultString: string;
FFullResult: TStringList; FFullResult: TStringList;
@ -101,9 +117,6 @@ type
function StartTLS: 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 IMAPHost: string read FIMAPHost Write FIMAPHost;
property IMAPPort: string read FIMAPPort Write FIMAPPort;
property ResultString: string read FResultString; property ResultString: string read FResultString;
property FullResult: TStringList read FFullResult; property FullResult: TStringList read FFullResult;
property IMAPcap: TStringList read FIMAPcap; property IMAPcap: TStringList read FIMAPcap;
@ -134,9 +147,9 @@ begin
FSock.CreateSocket; FSock.CreateSocket;
FSock.SizeRecvBuffer := 32768; FSock.SizeRecvBuffer := 32768;
FSock.SizeSendBuffer := 32768; FSock.SizeSendBuffer := 32768;
FSock.ConvertLineEnd := True;
FTimeout := 300000; FTimeout := 300000;
FIMAPhost := cLocalhost; FTargetPort := cIMAPProtocol;
FIMAPPort := cIMAPProtocol;
FUsername := ''; FUsername := '';
FPassword := ''; FPassword := '';
FTagCommand := 0; FTagCommand := 0;
@ -316,7 +329,8 @@ begin
FSock.CreateSocket; FSock.CreateSocket;
if FFullSSL then if FFullSSL then
FSock.SSLEnabled := True; FSock.SSLEnabled := True;
FSock.Connect(FIMAPHost, FIMAPPort); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;

35
mimeinln.pas

@ -3,15 +3,34 @@
|==============================================================================| |==============================================================================|
| Content: Inline MIME support procedures and functions | | Content: Inline MIME support procedures and functions |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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,2001. |

332
mimemess.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.007.004 | | Project : Delphree - Synapse | 002.001.001 |
|==============================================================================| |==============================================================================|
| Content: MIME message object | | Content: MIME message object |
|==============================================================================| |==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c)2000-2002. |
@ -48,10 +67,10 @@ type
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
procedure Clear; procedure Clear;
procedure EncodeHeaders(const Value: TStringList); procedure EncodeHeaders(const Value: TStrings);
procedure DecodeHeaders(const Value: TStringList); procedure DecodeHeaders(const Value: TStrings);
function FindHeader(Value: string): string; function FindHeader(Value: string): string;
procedure FindHeaderList(Value: string; const HeaderList: TStringList); procedure FindHeaderList(Value: string; const HeaderList: TStrings);
published published
property From: string read FFrom Write FFrom; property From: string read FFrom Write FFrom;
property ToList: TStringList read FToList; property ToList: TStringList read FToList;
@ -65,28 +84,29 @@ type
TMimeMess = class(TObject) TMimeMess = class(TObject)
private private
FPartList: TList; FMessagePart: TMimePart;
FLines: TStringList; FLines: TStringList;
FHeader: TMessHeader; FHeader: TMessHeader;
FMultipartType: string;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
procedure Clear; procedure Clear;
function AddPart: Integer; function AddPart(const PartParent: TMimePart): TMimePart;
procedure AddPartText(const Value: TStringList); function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
procedure AddPartHTML(const Value: TStringList); function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
procedure AddPartHTMLBinary(Value, Cid: string); function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
procedure AddPartBinary(Value: string); function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
procedure EncodeMessage; procedure EncodeMessage;
procedure FinalizeHeaders;
procedure ParseHeaders;
procedure DecodeMessage; procedure DecodeMessage;
published published
property PartList: TList read FPartList; property MessagePart: TMimePart read FMessagePart;
property Lines: TStringList read FLines; property Lines: TStringList read FLines;
property Header: TMessHeader read FHeader; property Header: TMessHeader read FHeader;
property MultipartType: string read FMultipartType Write FMultipartType;
end; end;
implementation implementation
@ -123,7 +143,7 @@ begin
FXMailer := ''; FXMailer := '';
end; end;
procedure TMessHeader.EncodeHeaders(const Value: TStringList); procedure TMessHeader.EncodeHeaders(const Value: TStrings);
var var
n: Integer; n: Integer;
s: string; s: string;
@ -162,7 +182,7 @@ begin
Value.Insert(0, 'From: ' + InlineEmail(FFrom)); Value.Insert(0, 'From: ' + InlineEmail(FFrom));
end; end;
procedure TMessHeader.DecodeHeaders(const Value: TStringList); procedure TMessHeader.DecodeHeaders(const Value: TStrings);
var var
s, t: string; s, t: string;
x: Integer; x: Integer;
@ -250,7 +270,7 @@ begin
end; end;
end; end;
procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStringList); procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
var var
n: integer; n: integer;
begin begin
@ -267,47 +287,58 @@ end;
constructor TMimeMess.Create; constructor TMimeMess.Create;
begin begin
inherited Create; inherited Create;
FPartList := TList.Create; FMessagePart := TMimePart.Create;
FLines := TStringList.Create; FLines := TStringList.Create;
FHeader := TMessHeader.Create; FHeader := TMessHeader.Create;
FMultipartType := 'Mixed';
end; end;
destructor TMimeMess.Destroy; destructor TMimeMess.Destroy;
begin begin
Clear; FMessagePart.Free;
FHeader.Free; FHeader.Free;
Lines.Free; FLines.Free;
PartList.Free;
inherited Destroy; inherited Destroy;
end; end;
{==============================================================================} {==============================================================================}
procedure TMimeMess.Clear; procedure TMimeMess.Clear;
var
n: Integer;
begin begin
FMultipartType := 'Mixed'; FMessagePart.Clear;
Lines.Clear; FLines.Clear;
for n := 0 to FPartList.Count - 1 do
TMimePart(FPartList[n]).Free;
FPartList.Clear;
FHeader.Clear; FHeader.Clear;
end; end;
{==============================================================================} {==============================================================================}
function TMimeMess.AddPart: Integer; function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
begin begin
Result := FPartList.Add(TMimePart.Create); if PartParent = nil then
Result := FMessagePart
else
Result := PartParent.AddSubPart;
Result.Clear;
end; end;
{==============================================================================} {==============================================================================}
procedure TMimeMess.AddPartText(const Value: TStringList); function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
begin begin
with TMimePart(FPartList[AddPart]) do Result := AddPart(PartParent);
with Result do
begin
Primary := 'Multipart';
Secondary := MultipartType;
Description := 'Multipart message';
Boundary := GenerateBoundary;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
with Result do
begin begin
Value.SaveToStream(DecodedLines); Value.SaveToStream(DecodedLines);
Primary := 'text'; Primary := 'text';
@ -319,14 +350,14 @@ begin
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]); ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
EncodingCode := ME_QUOTED_PRINTABLE; EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart; EncodePart;
EncodePartHeader;
end; end;
end; end;
{==============================================================================} function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
procedure TMimeMess.AddPartHTML(const Value: TStringList);
begin begin
with TMimePart(FPartList[AddPart]) do Result := AddPart(PartParent);
with Result do
begin begin
Value.SaveToStream(DecodedLines); Value.SaveToStream(DecodedLines);
Primary := 'text'; Primary := 'text';
@ -336,43 +367,86 @@ begin
CharsetCode := UTF_8; CharsetCode := UTF_8;
EncodingCode := ME_QUOTED_PRINTABLE; EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart; EncodePart;
EncodePartHeader;
end; end;
end; end;
{==============================================================================} function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
procedure TMimeMess.AddPartBinary(Value: string);
var var
s: string; tmp: TStrings;
begin begin
with TMimePart(FPartList[AddPart]) do tmp := TStringList.Create;
begin try
DecodedLines.LoadFromFile(Value); tmp.LoadFromFile(FileName);
s := ExtractFileName(Value); Result := AddPartText(tmp, PartParent);
MimeTypeFromExt(s); Finally
Description := 'Attached file: ' + s; tmp.Free;
Disposition := 'attachment';
FileName := s;
EncodingCode := ME_BASE64;
EncodePart;
end; end;
end; end;
procedure TMimeMess.AddPartHTMLBinary(Value, Cid: string); function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var var
s: string; tmp: TStrings;
begin begin
with TMimePart(FPartList[AddPart]) do tmp := TStringList.Create;
begin try
DecodedLines.LoadFromFile(Value); tmp.LoadFromFile(FileName);
s := ExtractFileName(Value); Result := AddPartHTML(tmp, PartParent);
MimeTypeFromExt(s); Finally
Description := 'Included file: ' + s; tmp.Free;
Disposition := 'inline'; end;
ContentID := Cid; end;
FileName := s;
EncodingCode := ME_BASE64; function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
EncodePart; begin
Result := AddPart(PartParent);
Result.DecodedLines.LoadFromStream(Stream);
Result.MimeTypeFromExt(FileName);
Result.Description := 'Attached file: ' + FileName;
Result.Disposition := 'attachment';
Result.FileName := FileName;
Result.EncodingCode := ME_BASE64;
Result.EncodePart;
Result.EncodePartHeader;
end;
function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
var
tmp: TMemoryStream;
begin
tmp := TMemoryStream.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
finally
tmp.Free;
end;
end;
function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
Result.DecodedLines.LoadFromStream(Stream);
Result.MimeTypeFromExt(FileName);
Result.Description := 'Included file: ' + FileName;
Result.Disposition := 'inline';
Result.ContentID := Cid;
Result.FileName := FileName;
Result.EncodingCode := ME_BASE64;
Result.EncodePart;
Result.EncodePartHeader;
end;
function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
var
tmp: TMemoryStream;
begin
tmp := TMemoryStream.Create;
try
tmp.LoadFromFile(FileName);
Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
finally
tmp.Free;
end; end;
end; end;
@ -380,96 +454,44 @@ end;
procedure TMimeMess.EncodeMessage; procedure TMimeMess.EncodeMessage;
var var
bound: string; l: TStringList;
n: Integer; x: integer;
m:TMimepart;
begin begin
FLines.Clear; //merge headers from THeaders and header field from MessagePart
if FPartList.Count = 1 then l := TStringList.Create;
begin try
TMimePart(FPartList[0]).EncodePart; FHeader.EncodeHeaders(l);
FLines.Assign(TMimePart(FPartList[0]).Lines) x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
end if x >= 0 then
else l.add(FMessagePart.Headers[x]);
begin x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
bound := GenerateBoundary; if x >= 0 then
for n := 0 to FPartList.Count - 1 do l.add(FMessagePart.Headers[x]);
begin x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
FLines.Add('--' + bound); if x >= 0 then
TMimePart(FPartList[n]).EncodePart; l.add(FMessagePart.Headers[x]);
FLines.AddStrings(TMimePart(FPartList[n]).Lines); x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
end; if x >= 0 then
FLines.Add('--' + bound + '--'); l.add(FMessagePart.Headers[x]);
m := TMimePart.Create; x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
try if x >= 0 then
FLines.SaveToStream(m.DecodedLines); l.add(FMessagePart.Headers[x]);
m.Primary := 'Multipart'; FMessagePart.Headers.Assign(l);
m.Secondary := FMultipartType; finally
m.Description := 'Multipart message'; l.Free;
m.Boundary := bound;
m.EncodePart;
FLines.Assign(m.Lines);
finally
m.Free;
end;
end; end;
end; FMessagePart.ComposeParts;
FLines.Assign(FMessagePart.Lines);
{==============================================================================}
procedure TMimeMess.FinalizeHeaders;
begin
FHeader.EncodeHeaders(FLines);
end;
{==============================================================================}
procedure TMimeMess.ParseHeaders;
begin
FHeader.DecodeHeaders(FLines);
end; end;
{==============================================================================} {==============================================================================}
procedure TMimeMess.DecodeMessage; procedure TMimeMess.DecodeMessage;
var
l: TStringList;
m: TMimePart;
i: Integer;
bound: string;
begin begin
l := TStringList.Create; FHeader.Clear;
m := TMimePart.Create; FHeader.DecodeHeaders(FLines);
try FMessagePart.Lines.Assign(FLines);
l.Assign(FLines); FMessagePart.DecomposeParts;
FHeader.Clear;
ParseHeaders;
m.ExtractPart(l, 0);
if m.PrimaryCode = MP_MULTIPART then
begin
bound := m.Boundary;
i := 0;
repeat
with TMimePart(PartList[AddPart]) do
begin
Boundary := bound;
i := ExtractPart(l, i);
DecodePart;
end;
until i >= l.Count - 2;
end
else
begin
with TMimePart(PartList[AddPart]) do
begin
ExtractPart(l, 0);
DecodePart;
end;
end;
finally
m.Free;
l.Free;
end;
end; end;
end. end.

721
mimepart.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.008.004 | | Project : Delphree - Synapse | 002.001.002 |
|==============================================================================| |==============================================================================|
| Content: MIME support procedures and functions | | Content: MIME support procedures and functions |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c)2000-2002. |
@ -29,10 +48,16 @@ interface
uses uses
SysUtils, Classes, SysUtils, Classes,
{$IFNDEF LINUX}
Windows,
{$ENDIF}
SynaChar, SynaCode, SynaUtil, MIMEinLn; SynaChar, SynaCode, SynaUtil, MIMEinLn;
type type
TMimePart = class;
THookWalkPart = procedure(const Sender: TMimePart) of object;
TMimePrimary = (MP_TEXT, MP_MULTIPART, TMimePrimary = (MP_TEXT, MP_MULTIPART,
MP_MESSAGE, MP_BINARY); MP_MESSAGE, MP_BINARY);
@ -42,22 +67,28 @@ type
TMimePart = class(TObject) TMimePart = class(TObject)
private private
FPrimary: string; FPrimary: string;
FEncoding: string;
FCharset: string;
FDefaultCharset: string;
FPrimaryCode: TMimePrimary; FPrimaryCode: TMimePrimary;
FSecondary: string;
FEncoding: string;
FEncodingCode: TMimeEncoding; FEncodingCode: TMimeEncoding;
FDefaultCharset: string;
FCharset: string;
FCharsetCode: TMimeChar; FCharsetCode: TMimeChar;
FTargetCharset: TMimeChar; FTargetCharset: TMimeChar;
FSecondary: string;
FDescription: string; FDescription: string;
FDisposition: string; FDisposition: string;
FContentID: string; FContentID: string;
FBoundary: string; FBoundary: string;
FFileName: string; FFileName: string;
FLines: TStringList; FLines: TStringList;
FPartBody: TStringList;
FHeaders: TStringList;
FPrePart: TStringList;
FPostPart: TStringList;
FDecodedLines: TMemoryStream; FDecodedLines: TMemoryStream;
FSkipLast: Boolean; FSubParts: TList;
FOnWalkPart: THookWalkPart;
FMaxLineLength: integer;
procedure SetPrimary(Value: string); procedure SetPrimary(Value: string);
procedure SetEncoding(Value: string); procedure SetEncoding(Value: string);
procedure SetCharset(Value: string); procedure SetCharset(Value: string);
@ -65,10 +96,18 @@ type
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
procedure Clear; procedure Clear;
function ExtractPart(Value: TStringList; BeginLine: Integer): Integer;
procedure DecodePart; procedure DecodePart;
procedure DecodePartHeader;
procedure EncodePart; procedure EncodePart;
procedure EncodePartHeader;
procedure MimeTypeFromExt(Value: string); procedure MimeTypeFromExt(Value: string);
function GetSubPartCount: integer;
function GetSubPart(index: integer): TMimePart;
procedure ClearSubParts;
function AddSubPart: TMimePart;
procedure DecomposeParts;
procedure ComposeParts;
procedure WalkPart;
published published
property Primary: string read FPrimary write SetPrimary; property Primary: string read FPrimary write SetPrimary;
property Encoding: string read FEncoding write SetEncoding; property Encoding: string read FEncoding write SetEncoding;
@ -85,8 +124,13 @@ type
property Boundary: string read FBoundary Write FBoundary; property Boundary: string read FBoundary Write FBoundary;
property FileName: string read FFileName Write FFileName; property FileName: string read FFileName Write FFileName;
property Lines: TStringList read FLines; property Lines: TStringList read FLines;
property PartBody: TStringList read FPartBody;
property Headers: TStringList read FHeaders;
property PrePart: TStringList read FPrePart;
property PostPart: TStringList read FPostPart;
property DecodedLines: TMemoryStream read FDecodedLines; property DecodedLines: TMemoryStream read FDecodedLines;
property SkipLast: Boolean read FSkipLast Write FSkipLast; property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart;
property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength;
end; end;
const const
@ -121,12 +165,12 @@ const
('ZIP', 'application', 'ZIP') ('ZIP', 'application', 'ZIP')
); );
function NormalizeHeader(Value: TStringList; var Index: Integer): string; function NormalizeHeader(Value: TStrings; var Index: Integer): string;
function GenerateBoundary: string; function GenerateBoundary: string;
implementation implementation
function NormalizeHeader(Value: TStringList; var Index: Integer): string; function NormalizeHeader(Value: TStrings; var Index: Integer): string;
var var
s, t: string; s, t: string;
n: Integer; n: Integer;
@ -150,7 +194,7 @@ begin
Inc(Index); Inc(Index);
end; end;
end; end;
Result := s; Result := TrimRight(s);
end; end;
{==============================================================================} {==============================================================================}
@ -158,17 +202,29 @@ end;
constructor TMIMEPart.Create; constructor TMIMEPart.Create;
begin begin
inherited Create; inherited Create;
FOnWalkPart := nil;
FLines := TStringList.Create; FLines := TStringList.Create;
FPartBody := TStringList.Create;
FHeaders := TStringList.Create;
FPrePart := TStringList.Create;
FPostPart := TStringList.Create;
FDecodedLines := TMemoryStream.Create; FDecodedLines := TMemoryStream.Create;
FSubParts := TList.Create;
FTargetCharset := GetCurCP; FTargetCharset := GetCurCP;
FDefaultCharset := 'US-ASCII'; FDefaultCharset := 'US-ASCII';
FSkipLast := True; FMaxLineLength := 78;
end; end;
destructor TMIMEPart.Destroy; destructor TMIMEPart.Destroy;
begin begin
ClearSubParts;
FSubParts.Free;
FDecodedLines.Free; FDecodedLines.Free;
FPartBody.Free;
FLines.Free; FLines.Free;
FHeaders.Free;
FPrePart.Free;
FPostPart.Free;
inherited Destroy; inherited Destroy;
end; end;
@ -189,51 +245,316 @@ begin
FDescription := ''; FDescription := '';
FBoundary := ''; FBoundary := '';
FFileName := ''; FFileName := '';
FLines.Clear; FPartBody.Clear;
FHeaders.Clear;
FPrePart.Clear;
FPostPart.Clear;
FDecodedLines.Clear; FDecodedLines.Clear;
ClearSubParts;
end; end;
{==============================================================================} {==============================================================================}
function TMIMEPart.ExtractPart(Value: TStringList; BeginLine: Integer): Integer; function TMIMEPart.GetSubPartCount: integer;
var
n, x, x1, x2: Integer;
t: TStringList;
s, su, b: string;
st, st2: string;
e: Boolean;
fn: string;
begin begin
t := TStringlist.Create; Result := FSubParts.Count;
try end;
{ defaults }
FLines.Clear;
Primary := 'text';
FSecondary := 'plain';
FDescription := '';
Charset := FDefaultCharset;
FFileName := '';
Encoding := '7BIT';
fn := ''; {==============================================================================}
x := BeginLine;
b := FBoundary;
{ if multipart - skip pre-part }
if b <> '' then
while Value.Count > x do
begin
s := Value[x];
Inc(x);
if Pos('--' + b, s) = 1 then
Break;
end;
{ parse header } function TMIMEPart.GetSubPart(index: integer): TMimePart;
while Value.Count > x do begin
Result := nil;
if Index < GetSubPartCount then
Result := TMimePart(FSubParts[Index]);
end;
{==============================================================================}
procedure TMIMEPart.ClearSubParts;
var
n: integer;
begin
for n := 0 to GetSubPartCount - 1 do
TMimePart(FSubParts[n]).Free;
FSubParts.Clear;
end;
{==============================================================================}
function TMIMEPart.AddSubPart: TMimePart;
begin
Result := TMimePart.Create;
Result.DefaultCharset := FDefaultCharset;
FSubParts.Add(Result);
end;
{==============================================================================}
procedure TMIMEPart.DecomposeParts;
var
x: integer;
s: string;
Mime: TMimePart;
procedure SkipEmpty;
begin
while FLines.Count > x do
begin begin
s := NormalizeHeader(Value, x); s := TrimRight(FLines[x]);
if s = '' then if s <> '' then
Break; Break;
Inc(x);
end;
end;
begin
x := 0;
Clear;
//extract headers
while FLines.Count > x do
begin
s := NormalizeHeader(FLines, x);
if s = '' then
Break;
FHeaders.Add(s);
end;
StringsTrim(FHeaders);
DecodePartHeader;
//extract prepart
if FPrimaryCode = MP_MULTIPART then
begin
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
if s = '--' + FBoundary then
Break;
FPrePart.Add(s);
end;
StringsTrim(FPrePart);
end;
//extract body part
if FPrimaryCode = MP_MULTIPART then
begin
repeat
Mime := AddSubPart;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
if Pos('--' + FBoundary, s) = 1 then
Break;
Mime.Lines.Add(s);
end;
StringsTrim(Mime.Lines);
Mime.DecomposeParts;
if x >= FLines.Count then
break;
until s = '--' + FBoundary + '--';
end;
if FPrimaryCode = MP_MESSAGE then
begin
Mime := AddSubPart;
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
Mime.Lines.Add(s);
end;
StringsTrim(Mime.Lines);
Mime.DecomposeParts;
end
else
begin
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
FPartBody.Add(s);
end;
StringsTrim(FPartBody);
end;
//extract postpart
if FPrimaryCode = MP_MULTIPART then
begin
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
Inc(x);
FPostPart.Add(s);
end;
StringsTrim(FPostPart);
end;
end;
{==============================================================================}
procedure TMIMEPart.ComposeParts;
var
n: integer;
mime: TMimePart;
s, t: string;
d1, d2, d3: integer;
x: integer;
begin
FLines.Clear;
//add headers
for n := 0 to FHeaders.Count -1 do
begin
s := FHeaders[n];
repeat
if Length(s) < FMaxLineLength then
begin
t := s;
s := '';
end
else
begin
d1 := RPosEx('; ', s, FMaxLineLength);
d2 := RPosEx(' ', s, FMaxLineLength);
d3 := RPosEx(', ', s, FMaxLineLength);
if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then
begin
x := Pos(' ', Copy(s, 2, Length(s) - 1));
if x < 1 then
x := Length(s)
else
inc(x);
end
else
if d1 > 0 then
x := d1
else
if d3 > 0 then
x := d3
else
x := d2 - 1;
t := Copy(s, 1, x);
Delete(s, 1, x);
end;
Flines.Add(t);
until s = '';
end;
Flines.Add('');
//add body
//if multipart
if FPrimaryCode = MP_MULTIPART then
begin
Flines.AddStrings(FPrePart);
Flines.Add('');
for n := 0 to GetSubPartCount - 1 do
begin
Flines.Add('--' + FBoundary);
mime := GetSubPart(n);
mime.ComposeParts;
FLines.AddStrings(mime.Lines);
Flines.Add('');
end;
Flines.Add('--' + FBoundary + '--');
Flines.AddStrings(FPostPart);
end;
//if message
if FPrimaryCode = MP_MESSAGE then
begin
if GetSubPartCount > 0 then
begin
mime := GetSubPart(0);
mime.ComposeParts;
FLines.AddStrings(mime.Lines);
Flines.Add('');
end;
end
else
//if normal part
begin
FLines.AddStrings(FPartBody);
Flines.Add('');
end;
end;
{==============================================================================}
procedure TMIMEPart.DecodePart;
const
CRLF = #13#10;
var
n: Integer;
s: string;
begin
FDecodedLines.Clear;
for n := 0 to FPartBody.Count - 1 do
begin
s := FPartBody[n];
case FEncodingCode of
ME_7BIT:
begin
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
s := s + CRLF;
end;
ME_8BIT:
begin
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
s := s + CRLF;
end;
ME_QUOTED_PRINTABLE:
begin
if s = '' then
s := CRLF
else
if s[Length(s)] <> '=' then
s := s + CRLF;
s := DecodeQuotedPrintable(s);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end;
ME_BASE64:
begin
if s <> '' then
s := DecodeBase64(s);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end;
ME_UU:
if s <> '' then
s := DecodeUU(s);
ME_XX:
if s <> '' then
s := DecodeXX(s);
end;
FDecodedLines.Write(Pointer(s)^, Length(s));
end;
FDecodedLines.Seek(0, soFromBeginning);
end;
{==============================================================================}
procedure TMIMEPart.DecodePartHeader;
var
n: integer;
s, su, fn: string;
st, st2: string;
begin
Primary := 'text';
FSecondary := 'plain';
FDescription := '';
Charset := FDefaultCharset;
FFileName := '';
Encoding := '7BIT';
FDisposition := '';
FContentID := '';
fn := '';
for n := 0 to FHeaders.Count - 1 do
if FHeaders[n] <> '' then
begin
s := FHeaders[n];
su := UpperCase(s); su := UpperCase(s);
if Pos('CONTENT-TYPE:', su) = 1 then if Pos('CONTENT-TYPE:', su) = 1 then
begin begin
@ -271,141 +592,10 @@ begin
if Pos('CONTENT-ID:', su) = 1 then if Pos('CONTENT-ID:', su) = 1 then
FContentID := SeparateRight(s, ':'); FContentID := SeparateRight(s, ':');
end; end;
if (PrimaryCode = MP_BINARY) and (FFileName = '') then
if (PrimaryCode = MP_BINARY) and (FFileName = '') then FFileName := fn;
FFileName := fn; FFileName := InlineDecode(FFileName, getCurCP);
FFileName := InlineDecode(FFileName, getCurCP); FFileName := ExtractFileName(FFileName);
FFileName := ExtractFileName(FFileName);
{ finding part content x1-begin x2-end }
x1 := x;
x2 := Value.Count - 1;
{ if multipart - end is before next boundary }
if b <> '' then
begin
for n := x to Value.Count - 1 do
begin
x2 := n;
s := Value[n];
if Pos('--' + b, s) = 1 then
begin
Dec(x2);
Break;
end;
end;
end;
{ if content is multipart - content is delimited by their boundaries }
if FPrimaryCode = MP_MULTIPART then
begin
for n := x to Value.Count - 1 do
begin
s := Value[n];
if Pos('--' + FBoundary, s) = 1 then
begin
x1 := n;
Break;
end;
end;
for n := Value.Count - 1 downto x do
begin
s := Value[n];
if Pos('--' + FBoundary, s) = 1 then
begin
x2 := n;
Break;
end;
end;
end;
{ copy content }
for n := x1 to x2 do
FLines.Add(Value[n]);
Result := x2;
{ if content is multipart - find real end }
if FPrimaryCode = MP_MULTIPART then
begin
e := False;
for n := x2 + 1 to Value.Count - 1 do
if Pos('--' + b, Value[n]) = 1 then
begin
e := True;
Break;
end;
if not e then
Result := Value.Count - 1;
end;
{ if multipart - skip ending postpart}
if b <> '' then
begin
x1 := Result;
for n := x1 to Value.Count - 1 do
begin
s := Value[n];
if Pos('--' + b, s) = 1 then
begin
s := TrimRight(s);
if s = ('--' + b + '--') then
if FSkipLast then
Result := Value.Count - 1
else
Result := n + 1;
Break;
end;
end;
end;
finally
t.Free;
end;
end;
{==============================================================================}
procedure TMIMEPart.DecodePart;
const
CRLF = #13#10;
var
n: Integer;
s: string;
begin
FDecodedLines.Clear;
for n := 0 to FLines.Count - 1 do
begin
s := FLines[n];
case FEncodingCode of
ME_7BIT:
s := s + CRLF;
ME_8BIT:
begin
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
s := s + CRLF;
end;
ME_QUOTED_PRINTABLE:
begin
if s = '' then
s := CRLF
else
if s[Length(s)] <> '=' then
s := s + CRLF;
s := DecodeQuotedPrintable(s);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end;
ME_BASE64:
begin
if s <> '' then
s := DecodeBase64(s);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end;
ME_UU:
if s <> '' then
s := DecodeUU(s);
ME_XX:
if s <> '' then
s := DecodeXX(s);
end;
FDecodedLines.Write(Pointer(s)^, Length(s));
end;
FDecodedLines.Seek(0, soFromBeginning);
end; end;
{==============================================================================} {==============================================================================}
@ -416,18 +606,16 @@ var
s, t: string; s, t: string;
n, x: Integer; n, x: Integer;
d1, d2: integer; d1, d2: integer;
const
MaxLine = 75;
begin begin
if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
Encoding := 'base64'; Encoding := 'base64';
l := TStringList.Create; l := TStringList.Create;
FLines.Clear; FPartBody.Clear;
FDecodedLines.Seek(0, soFromBeginning); FDecodedLines.Seek(0, soFromBeginning);
try try
case FPrimaryCode of case FPrimaryCode of
MP_MULTIPART, MP_MESSAGE: MP_MULTIPART, MP_MESSAGE:
FLines.LoadFromStream(FDecodedLines); FPartBody.LoadFromStream(FDecodedLines);
MP_TEXT, MP_BINARY: MP_TEXT, MP_BINARY:
if FEncodingCode = ME_BASE64 then if FEncodingCode = ME_BASE64 then
begin begin
@ -439,7 +627,7 @@ begin
if FPrimaryCode = MP_TEXT then if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FTargetCharset, FCharsetCode); s := CharsetConversion(s, FTargetCharset, FCharsetCode);
s := EncodeBase64(s); s := EncodeBase64(s);
FLines.Add(s); FPartBody.Add(s);
end; end;
end end
else else
@ -454,85 +642,37 @@ begin
begin begin
s := EncodeQuotedPrintable(s); s := EncodeQuotedPrintable(s);
repeat repeat
if Length(s) < MaxLine then if Length(s) < FMaxLineLength then
begin begin
t := s; t := s;
s := ''; s := '';
end end
else else
begin begin
d1 := RPosEx('=', s, MaxLine); d1 := RPosEx('=', s, FMaxLineLength);
d2 := RPosEx(' ', s, MaxLine); d2 := RPosEx(' ', s, FMaxLineLength);
if (d1 = 0) and (d2 = 0) then if (d1 = 0) and (d2 = 0) then
x := MaxLine x := FMaxLineLength
else else
if d1 > d2 then if d1 > d2 then
x := d1 - 1 x := d1 - 1
else else
x := d2 - 1; x := d2 - 1;
if x = 0 then
x := FMaxLineLength;
t := Copy(s, 1, x); t := Copy(s, 1, x);
s := Copy(s, x + 1, Length(s) - x); s := Copy(s, x + 1, Length(s) - x);
if s <> '' then if s <> '' then
t := t + '='; t := t + '=';
end; end;
FLines.Add(t); FPartBody.Add(t);
until s = ''; until s = '';
end end
else else
FLines.Add(s); FPartBody.Add(s);
end; end;
end; end;
end; end;
FLines.Add('');
FLines.Insert(0, '');
if FSecondary = '' then
case FPrimaryCode of
MP_TEXT:
FSecondary := 'plain';
MP_MULTIPART:
FSecondary := 'mixed';
MP_MESSAGE:
FSecondary := 'rfc822';
MP_BINARY:
FSecondary := 'octet-stream';
end;
if FDescription <> '' then
FLines.Insert(0, 'Content-Description: ' + FDescription);
if FDisposition <> '' then
begin
s := '';
if FFileName <> '' then
s := '; FileName="' + FFileName + '"';
FLines.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
end;
if FContentID <> '' then
FLines.Insert(0, 'Content-ID: ' + FContentID);
case FEncodingCode of
ME_7BIT:
s := '7bit';
ME_8BIT:
s := '8bit';
ME_QUOTED_PRINTABLE:
s := 'Quoted-printable';
ME_BASE64:
s := 'Base64';
end;
case FPrimaryCode of
MP_TEXT,
MP_BINARY: FLines.Insert(0, 'Content-Transfer-Encoding: ' + s);
end;
case FPrimaryCode of
MP_TEXT:
s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
MP_MULTIPART:
s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"';
MP_MESSAGE:
s := FPrimary + '/' + FSecondary + '';
MP_BINARY:
s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"';
end;
FLines.Insert(0, 'Content-type: ' + s);
finally finally
l.Free; l.Free;
end; end;
@ -540,6 +680,63 @@ end;
{==============================================================================} {==============================================================================}
procedure TMIMEPart.EncodePartHeader;
var
s: string;
begin
FHeaders.Clear;
if FSecondary = '' then
case FPrimaryCode of
MP_TEXT:
FSecondary := 'plain';
MP_MULTIPART:
FSecondary := 'mixed';
MP_MESSAGE:
FSecondary := 'rfc822';
MP_BINARY:
FSecondary := 'octet-stream';
end;
if FDescription <> '' then
FHeaders.Insert(0, 'Content-Description: ' + FDescription);
if FDisposition <> '' then
begin
s := '';
if FFileName <> '' then
s := '; FileName="' + FFileName + '"';
FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
end;
if FContentID <> '' then
FHeaders.Insert(0, 'Content-ID: ' + FContentID);
case FEncodingCode of
ME_7BIT:
s := '7bit';
ME_8BIT:
s := '8bit';
ME_QUOTED_PRINTABLE:
s := 'Quoted-printable';
ME_BASE64:
s := 'Base64';
end;
case FPrimaryCode of
MP_TEXT,
MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s);
end;
case FPrimaryCode of
MP_TEXT:
s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
MP_MULTIPART:
s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"';
MP_MESSAGE:
s := FPrimary + '/' + FSecondary + '';
MP_BINARY:
s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"';
end;
FHeaders.Insert(0, 'Content-type: ' + s);
end;
{==============================================================================}
procedure TMIMEPart.MimeTypeFromExt(Value: string); procedure TMIMEPart.MimeTypeFromExt(Value: string);
var var
s: string; s: string;
@ -566,6 +763,25 @@ end;
{==============================================================================} {==============================================================================}
procedure TMIMEPart.WalkPart;
var
n: integer;
m: TMimepart;
begin
if assigned(OnWalkPart) then
begin
OnWalkPart(self);
for n := 0 to GetSubPartCount - 1 do
begin
m := GetSubPart(n);
m.OnWalkPart := OnWalkPart;
m.WalkPart;
end;
end;
end;
{==============================================================================}
procedure TMIMEPart.SetPrimary(Value: string); procedure TMIMEPart.SetPrimary(Value: string);
var var
s: string; s: string;
@ -612,9 +828,10 @@ function GenerateBoundary: string;
var var
x: Integer; x: Integer;
begin begin
Sleep(1);
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.

54
nntpsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.000.000 | | Project : Delphree - Synapse | 001.001.000 |
|==============================================================================| |==============================================================================|
| Content: NNTP client | | Content: NNTP client |
|==============================================================================| |==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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,2000,2001. |
@ -37,12 +56,9 @@ const
cNNTPProtocol = 'nntp'; cNNTPProtocol = 'nntp';
type type
TNNTPSend = class(TObject) TNNTPSend = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FTimeout: Integer;
FNNTPHost: string;
FNNTPPort: string;
FResultCode: Integer; FResultCode: Integer;
FResultString: string; FResultString: string;
FData: TStringList; FData: TStringList;
@ -69,9 +85,6 @@ type
function PostArticle: Boolean; function PostArticle: Boolean;
function SwitchToSlave: Boolean; function SwitchToSlave: Boolean;
published published
property Timeout: Integer read FTimeout Write FTimeout;
property NNTPHost: string read FNNTPHost Write FNNTPHost;
property NNTPPort: string read FNNTPPort Write FNNTPPort;
property ResultCode: Integer read FResultCode; property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString; property ResultString: string read FResultString;
property Data: TStringList read FData; property Data: TStringList read FData;
@ -89,9 +102,9 @@ begin
FData := TStringList.Create; FData := TStringList.Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.CreateSocket; FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FTimeout := 300000; FTimeout := 300000;
FNNTPhost := cLocalhost; FTargetPort := cNNTPProtocol;
FNNTPPort := cNNTPProtocol;
end; end;
destructor TNNTPSend.Destroy; destructor TNNTPSend.Destroy;
@ -120,7 +133,6 @@ function TNNTPSend.ReadData: boolean;
var var
s: string; s: string;
begin begin
Result := False;
repeat repeat
s := FSock.RecvString(FTimeout); s := FSock.RecvString(FTimeout);
if s = '.' then if s = '.' then
@ -137,7 +149,6 @@ var
s: string; s: string;
n: integer; n: integer;
begin begin
Result := False;
for n := 0 to FData.Count -1 do for n := 0 to FData.Count -1 do
begin begin
s := FData[n]; s := FData[n];
@ -154,7 +165,8 @@ function TNNTPSend.Connect: Boolean;
begin begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.CreateSocket; FSock.CreateSocket;
FSock.Connect(FNNTPHost, FNNTPPort); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;

44
pingsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.002.000 | | Project : Delphree - Synapse | 002.003.001 |
|==============================================================================| |==============================================================================|
| Content: PING sender | | Content: PING sender |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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,2001. |
@ -59,13 +78,12 @@ type
TimeStamp: ULONG; TimeStamp: ULONG;
end; end;
TPINGSend = class(TObject) TPINGSend = class(TSynaClient)
private private
FSock: TICMPBlockSocket; FSock: TICMPBlockSocket;
FBuffer: string; FBuffer: string;
FSeq: Integer; FSeq: Integer;
FId: Integer; FId: Integer;
FTimeout: Integer;
FPacketSize: Integer; FPacketSize: Integer;
FPingTime: Integer; FPingTime: Integer;
function Checksum: Integer; function Checksum: Integer;
@ -75,7 +93,6 @@ type
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
published published
property Timeout: Integer read FTimeout Write FTimeout;
property PacketSize: Integer read FPacketSize Write FPacketSize; property PacketSize: Integer read FPacketSize Write FPacketSize;
property PingTime: Integer read FPingTime; property PingTime: Integer read FPingTime;
property Sock: TICMPBlockSocket read FSock; property Sock: TICMPBlockSocket read FSock;
@ -119,6 +136,7 @@ var
t: Boolean; t: Boolean;
begin begin
Result := False; Result := False;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(Host, '0'); FSock.Connect(Host, '0');
FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize); FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize);
IcmpEchoHeaderPtr := Pointer(FBuffer); IcmpEchoHeaderPtr := Pointer(FBuffer);
@ -144,7 +162,7 @@ begin
IPHeadPtr := Pointer(FBuffer); IPHeadPtr := Pointer(FBuffer);
IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4; IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1]; IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
until IcmpEchoHeaderPtr^.i_type <> ICMP_ECHO; until (IcmpEchoHeaderPtr^.i_type <> ICMP_ECHO) and (IcmpEchoHeaderPtr^.i_id = FId);
//it discard sometimes possible 'echoes' of previosly sended packet... //it discard sometimes possible 'echoes' of previosly sended packet...
if t then if t then
if (IcmpEchoHeaderPtr^.i_type = ICMP_ECHOREPLY) then if (IcmpEchoHeaderPtr^.i_type = ICMP_ECHOREPLY) then

52
pop3send.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.000.000 | | Project : Delphree - Synapse | 002.001.000 |
|==============================================================================| |==============================================================================|
| Content: POP3 client | | Content: POP3 client |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c)2001-2002. |
@ -45,12 +64,9 @@ const
type type
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
TPOP3Send = class(TObject) TPOP3Send = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FTimeout: Integer;
FPOP3Host: string;
FPOP3Port: string;
FResultCode: Integer; FResultCode: Integer;
FResultString: string; FResultString: string;
FFullResult: TStringList; FFullResult: TStringList;
@ -84,9 +100,6 @@ type
function StartTLS: 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 POP3Host: string read FPOP3Host Write FPOP3Host;
property POP3Port: string read FPOP3Port Write FPOP3Port;
property ResultCode: Integer read FResultCode; property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString; property ResultString: string read FResultString;
property FullResult: TStringList read FFullResult; property FullResult: TStringList read FFullResult;
@ -113,9 +126,9 @@ begin
FPOP3cap := TStringList.Create; FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.CreateSocket; FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FTimeout := 300000; FTimeout := 300000;
FPOP3host := cLocalhost; FTargetPort := cPop3Protocol;
FPOP3Port := cPop3Protocol;
FUsername := ''; FUsername := '';
FPassword := ''; FPassword := '';
FStatCount := 0; FStatCount := 0;
@ -182,7 +195,8 @@ begin
FSock.CreateSocket; FSock.CreateSocket;
if FFullSSL then if FFullSSL then
FSock.SSLEnabled := True; FSock.SSLEnabled := True;
FSock.Connect(POP3Host, POP3Port); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;

55
slogsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.000.001 | | Project : Delphree - Synapse | 001.001.000 |
|==============================================================================| |==============================================================================|
| Content: SysLog client | | Content: SysLog client |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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. |
@ -68,10 +87,8 @@ type
TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
Debug); Debug);
TSyslogSend = class(TObject) TSyslogSend = class(TSynaClient)
private private
FSyslogHost: string;
FSyslogPort: string;
FSock: TUDPBlockSocket; FSock: TUDPBlockSocket;
FFacility: Byte; FFacility: Byte;
FSeverity: TSyslogSeverity; FSeverity: TSyslogSeverity;
@ -82,8 +99,6 @@ type
destructor Destroy; override; destructor Destroy; override;
function DoIt: Boolean; function DoIt: Boolean;
published published
property SyslogHost: string read FSyslogHost Write FSyslogHost;
property SyslogPort: string read FSyslogPort Write FSyslogPort;
property Facility: Byte read FFacility Write FFacility; property Facility: Byte read FFacility Write FFacility;
property Severity: TSyslogSeverity read FSeverity Write FSeverity; property Severity: TSyslogSeverity read FSeverity Write FSeverity;
property Tag: string read FTag Write FTag; property Tag: string read FTag Write FTag;
@ -100,12 +115,12 @@ begin
inherited Create; inherited Create;
FSock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
FSock.CreateSocket; FSock.CreateSocket;
FSyslogHost := cLocalhost; FTargetPort := cSysLogProtocol;
FSyslogPort := cSysLogProtocol;
FFacility := FCL_Local0; FFacility := FCL_Local0;
FSeverity := Debug; FSeverity := Debug;
FTag := ExtractFileName(ParamStr(0)); FTag := ExtractFileName(ParamStr(0));
FMessage := ''; FMessage := '';
FIPInterface := cAnyHost;
end; end;
destructor TSyslogSend.Destroy; destructor TSyslogSend.Destroy;
@ -138,8 +153,10 @@ begin
if Length(Buf) <= 1024 then if Length(Buf) <= 1024 then
begin begin
if FSock.EnableReuse(True) then if FSock.EnableReuse(True) then
Fsock.Bind('0.0.0.0', FSyslogPort); Fsock.Bind(FIPInterface, FTargetPort)
FSock.Connect(FSyslogHost, FSyslogPort); else
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(Buf); FSock.SendString(Buf);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
@ -153,7 +170,7 @@ begin
Result := False; Result := False;
with TSyslogSend.Create do with TSyslogSend.Create do
try try
SyslogHost :=SyslogServer; TargetHost :=SyslogServer;
Facility := Facil; Facility := Facil;
Severity := Sever; Severity := Sever;
LogMessage := Content; LogMessage := Content;

58
smtpsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 003.001.000 | | Project : Delphree - Synapse | 003.002.001 |
|==============================================================================| |==============================================================================|
| Content: SMTP client | | Content: SMTP client |
|==============================================================================| |==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
@ -37,12 +56,9 @@ const
cSmtpProtocol = 'smtp'; cSmtpProtocol = 'smtp';
type type
TSMTPSend = class(TObject) TSMTPSend = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FTimeout: Integer;
FSMTPHost: string;
FSMTPPort: string;
FResultCode: Integer; FResultCode: Integer;
FResultString: string; FResultString: string;
FFullResult: TStringList; FFullResult: TStringList;
@ -82,9 +98,6 @@ type
function EnhCodeString: string; function EnhCodeString: string;
function FindCap(const Value: string): string; function FindCap(const Value: string): string;
published published
property Timeout: Integer read FTimeout Write FTimeout;
property SMTPHost: string read FSMTPHost Write FSMTPHost;
property SMTPPort: string read FSMTPPort Write FSMTPPort;
property ResultCode: Integer read FResultCode; property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString; property ResultString: string read FResultString;
property FullResult: TStringList read FFullResult; property FullResult: TStringList read FFullResult;
@ -123,9 +136,9 @@ begin
FESMTPcap := TStringList.Create; FESMTPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.CreateSocket; FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FTimeout := 300000; FTimeout := 300000;
FSMTPhost := cLocalhost; FTargetPort := cSmtpProtocol;
FSMTPPort := cSmtpProtocol;
FUsername := ''; FUsername := '';
FPassword := ''; FPassword := '';
FSystemName := FSock.LocalName; FSystemName := FSock.LocalName;
@ -232,7 +245,8 @@ begin
FSock.CreateSocket; FSock.CreateSocket;
if FFullSSL then if FFullSSL then
FSock.SSLEnabled := True; FSock.SSLEnabled := True;
FSock.Connect(FSMTPHost, FSMTPPort); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
@ -302,8 +316,6 @@ begin
if (Pos('LOGIN', auths) > 0) and (not FauthDone) then if (Pos('LOGIN', auths) > 0) and (not FauthDone) then
FAuthDone := AuthLogin; FAuthDone := AuthLogin;
end; end;
if FAuthDone then
Ehlo;
end; end;
s := FindCap('SIZE'); s := FindCap('SIZE');
if s <> '' then if s <> '' then
@ -498,10 +510,10 @@ begin
// SMTP.AutoTLS := True; // SMTP.AutoTLS := True;
// if you need support for TSL/SSL tunnel, uncomment next lines: // if you need support for TSL/SSL tunnel, uncomment next lines:
// SMTP.FullSSL := True; // SMTP.FullSSL := True;
SMTP.SMTPHost := SeparateLeft(SMTPHost, ':'); SMTP.TargetHost := SeparateLeft(SMTPHost, ':');
s := SeparateRight(SMTPHost, ':'); s := SeparateRight(SMTPHost, ':');
if (s <> '') and (s <> SMTPHost) then if (s <> '') and (s <> SMTPHost) then
SMTP.SMTPPort := s; SMTP.TargetPort := s;
SMTP.Username := Username; SMTP.Username := Username;
SMTP.Password := Password; SMTP.Password := Password;
if SMTP.Login then if SMTP.Login then

128
snmpsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.003.006 | | Project : Delphree - Synapse | 002.005.000 |
|==============================================================================| |==============================================================================|
| Content: SNMP client | | Content: SNMP client |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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,2001. |
@ -93,12 +112,10 @@ type
property SNMPMibList: TList read FSNMPMibList; property SNMPMibList: TList read FSNMPMibList;
end; end;
TSNMPSend = class(TObject) TSNMPSend = class(TSynaClient)
private private
FSock: TUDPBlockSocket; FSock: TUDPBlockSocket;
FBuffer: string; FBuffer: string;
FTimeout: Integer;
FHost: string;
FHostIP: string; FHostIP: string;
FQuery: TSNMPRec; FQuery: TSNMPRec;
FReply: TSNMPRec; FReply: TSNMPRec;
@ -107,8 +124,6 @@ type
destructor Destroy; override; destructor Destroy; override;
function DoIt: Boolean; function DoIt: Boolean;
published published
property Timeout: Integer read FTimeout write FTimeout;
property Host: string read FHost write FHost;
property HostIP: string read FHostIP; property HostIP: string read FHostIP;
property Query: TSNMPRec read FQuery; property Query: TSNMPRec read FQuery;
property Reply: TSNMPRec read FReply; property Reply: TSNMPRec read FReply;
@ -117,6 +132,9 @@ type
function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): Boolean; function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): Boolean;
function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean; function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean;
function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean;
function SNMPGetTable(const BaseOID, Community, SNMPHost: string; const Value: TStrings): Boolean;
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean;
implementation implementation
@ -278,7 +296,7 @@ begin
FSock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
FSock.CreateSocket; FSock.CreateSocket;
FTimeout := 5000; FTimeout := 5000;
FHost := cLocalhost; FTargetPort := cSnmpProtocol;
FHostIP := ''; FHostIP := '';
end; end;
@ -294,8 +312,9 @@ function TSNMPSend.DoIt: Boolean;
begin begin
FReply.Clear; FReply.Clear;
FBuffer := FQuery.EncodeBuf; FBuffer := FQuery.EncodeBuf;
FSock.Connect(FHost, cSnmpProtocol); FSock.Bind(FIPInterface, cAnyPort);
FHostIP := '0.0.0.0'; FSock.Connect(FTargetHost, FTargetPort);
FHostIP := cAnyHost;
FSock.SendString(FBuffer); FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout); FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
@ -319,12 +338,11 @@ begin
SNMPSend.Query.Community := Community; SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUGetRequest; SNMPSend.Query.PDUType := PDUGetRequest;
SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
SNMPSend.Host := SNMPHost; SNMPSend.TargetHost := SNMPHost;
Result := SNMPSend.DoIt; Result := SNMPSend.DoIt;
Value := '';
if Result then if Result then
Value := SNMPSend.Reply.MIBGet(OID) Value := SNMPSend.Reply.MIBGet(OID);
else
Value := '';
finally finally
SNMPSend.Free; SNMPSend.Free;
end; end;
@ -340,13 +358,79 @@ begin
SNMPSend.Query.Community := Community; SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUSetRequest; SNMPSend.Query.PDUType := PDUSetRequest;
SNMPSend.Query.MIBAdd(OID, Value, ValueType); SNMPSend.Query.MIBAdd(OID, Value, ValueType);
SNMPSend.Host := SNMPHost; SNMPSend.TargetHost := SNMPHost;
Result := SNMPSend.DoIt = True; Result := SNMPSend.DoIt = True;
finally finally
SNMPSend.Free; SNMPSend.Free;
end; end;
end; end;
function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean;
var
SNMPSend: TSNMPSend;
begin
SNMPSend := TSNMPSend.Create;
try
SNMPSend.Query.Clear;
SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUGetNextRequest;
SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
SNMPSend.TargetHost := SNMPHost;
Result := SNMPSend.DoIt;
Value := '';
if Result then
if SNMPSend.Reply.SNMPMibList.Count > 0 then
begin
OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID;
Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value;
end;
finally
SNMPSend.Free;
end;
end;
function SNMPGetTable(const BaseOID, Community, SNMPHost: string; const Value: TStrings): Boolean;
var
OID: string;
s: string;
col,row: string;
lastcol: string;
x, n: integer;
begin
Value.Clear;
OID := BaseOID;
lastcol := '';
x := 0;
repeat
Result := SNMPGetNext(OID, Community, SNMPHost, s);
if Pos(BaseOID, OID) <> 1 then
break;
row := separateright(oid, baseoid + '.');
col := fetch(row, '.');
if col = lastcol then
inc(x)
else
x:=0;
lastcol := col;
if value.count <= x then
for n := value.Count - 1 to x do
value.add('');
if value[x] <> '' then
value[x] := value[x] + ',';
if IsBinaryString(s) then
s := StrToHex(s);
value[x] := value[x] + AnsiQuotedStr(s, '"');
until not result;
end;
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean;
var
s: string;
begin
s := BaseOID + '.' + ColID + '.' + RowID;
Result := SnmpGet(s, Community, SNMPHost, Value);
end;
end. end.

62
snmptrap.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.002.004 | | Project : Delphree - Synapse | 002.003.000 |
|==============================================================================| |==============================================================================|
| Content: SNMP traps | | Content: SNMP traps |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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 Hernan Sanchez are Copyright (c)2000,2001. | | Portions created by Hernan Sanchez are Copyright (c)2000,2001. |
@ -50,7 +69,6 @@ type
TTrapPDU = class(TObject) TTrapPDU = class(TObject)
private private
FBuffer: string; FBuffer: string;
FTrapPort: string;
FVersion: Integer; FVersion: Integer;
FPDUType: Integer; FPDUType: Integer;
FCommunity: string; FCommunity: string;
@ -73,7 +91,6 @@ type
property Version: Integer read FVersion Write FVersion; property Version: Integer read FVersion Write FVersion;
property Community: string read FCommunity Write FCommunity; property Community: string read FCommunity Write FCommunity;
property PDUType: Integer read FPDUType Write FPDUType; property PDUType: Integer read FPDUType Write FPDUType;
property TrapPort: string read FTrapPort Write FTrapPort;
property Enterprise: string read FEnterprise Write FEnterprise; property Enterprise: string read FEnterprise Write FEnterprise;
property TrapHost: string read FTrapHost Write FTrapHost; property TrapHost: string read FTrapHost Write FTrapHost;
property GenTrap: Integer read FGenTrap Write FGenTrap; property GenTrap: Integer read FGenTrap Write FGenTrap;
@ -82,12 +99,10 @@ type
property SNMPMibList: TList read FSNMPMibList; property SNMPMibList: TList read FSNMPMibList;
end; end;
TTrapSNMP = class(TObject) TTrapSNMP = class(TSynaClient)
private private
FSock: TUDPBlockSocket; FSock: TUDPBlockSocket;
FTrap: TTrapPDU; FTrap: TTrapPDU;
FSNMPHost: string;
FTimeout: Integer;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
@ -95,8 +110,6 @@ type
function Recv: Integer; function Recv: Integer;
published published
property Trap: TTrapPDU read FTrap; property Trap: TTrapPDU read FTrap;
property SNMPHost: string read FSNMPHost Write FSNMPHost;
property Timeout: Integer read FTimeout Write FTimeout;
property Sock: TUDPBlockSocket read FSock; property Sock: TUDPBlockSocket read FSock;
end; end;
@ -113,7 +126,6 @@ constructor TTrapPDU.Create;
begin begin
inherited Create; inherited Create;
FSNMPMibList := TList.Create; FSNMPMibList := TList.Create;
FTrapPort := cSnmpTrapProtocol;
FVersion := SNMP_VERSION; FVersion := SNMP_VERSION;
FPDUType := PDU_TRAP; FPDUType := PDU_TRAP;
FCommunity := 'public'; FCommunity := 'public';
@ -136,7 +148,6 @@ begin
for i := 0 to FSNMPMibList.Count - 1 do for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free; TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Clear; FSNMPMibList.Clear;
FTrapPort := cSnmpTrapProtocol;
FVersion := SNMP_VERSION; FVersion := SNMP_VERSION;
FPDUType := PDU_TRAP; FPDUType := PDU_TRAP;
FCommunity := 'public'; FCommunity := 'public';
@ -261,10 +272,10 @@ constructor TTrapSNMP.Create;
begin begin
inherited Create; inherited Create;
FSock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTrap := TTrapPDU.Create; FTrap := TTrapPDU.Create;
FTimeout := 5000; FTimeout := 5000;
FSNMPHost := cLocalhost; FTargetPort := cSnmpTrapProtocol;
FSock.CreateSocket;
end; end;
destructor TTrapSNMP.Destroy; destructor TTrapSNMP.Destroy;
@ -277,7 +288,8 @@ end;
function TTrapSNMP.Send: Integer; function TTrapSNMP.Send: Integer;
begin begin
FTrap.EncodeTrap; FTrap.EncodeTrap;
FSock.Connect(SNMPHost, FTrap.TrapPort); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FTrap.FBuffer); FSock.SendString(FTrap.FBuffer);
Result := 1; Result := 1;
end; end;
@ -285,7 +297,7 @@ end;
function TTrapSNMP.Recv: Integer; function TTrapSNMP.Recv: Integer;
begin begin
Result := 0; Result := 0;
FSock.Bind('0.0.0.0', FTrap.TrapPort); FSock.Bind(FIPInterface, FTargetPort);
FTrap.FBuffer := FSock.RecvPacket(FTimeout); FTrap.FBuffer := FSock.RecvPacket(FTimeout);
if Fsock.Lasterror = 0 then if Fsock.Lasterror = 0 then
if FTrap.DecodeTrap then if FTrap.DecodeTrap then
@ -298,7 +310,7 @@ function SendTrap(const Dest, Source, Enterprise, Community: string;
begin begin
with TTrapSNMP.Create do with TTrapSNMP.Create do
try try
SNMPHost := Dest; TargetHost := Dest;
Trap.TrapHost := Source; Trap.TrapHost := Source;
Trap.Enterprise := Enterprise; Trap.Enterprise := Enterprise;
Trap.Community := Community; Trap.Community := Community;
@ -320,11 +332,11 @@ var
begin begin
with TTrapSNMP.Create do with TTrapSNMP.Create do
try try
SNMPHost := Dest; TargetHost := Dest;
Result := Recv; Result := Recv;
if Result <> 0 then if Result <> 0 then
begin begin
Dest := SNMPHost; Dest := TargetHost;
Source := Trap.TrapHost; Source := Trap.TrapHost;
Enterprise := Trap.Enterprise; Enterprise := Trap.Enterprise;
Community := Trap.Community; Community := Trap.Community;

55
sntpsend.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.001.000 | | Project : Delphree - Synapse | 002.002.000 |
|==============================================================================| |==============================================================================|
| Content: SNTP client | | Content: SNTP client |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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,2001. |
@ -58,7 +77,7 @@ type
Xmit2: Longint; Xmit2: Longint;
end; end;
TSNTPSend = class(TObject) TSNTPSend = class(TSynaClient)
private private
FNTPReply: TNtp; FNTPReply: TNtp;
FNTPTime: TDateTime; FNTPTime: TDateTime;
@ -66,8 +85,6 @@ type
FNTPDelay: double; FNTPDelay: double;
FMaxSyncDiff: double; FMaxSyncDiff: double;
FSyncTime: Boolean; FSyncTime: Boolean;
FSntpHost: string;
FTimeout: Integer;
FSock: TUDPBlockSocket; FSock: TUDPBlockSocket;
FBuffer: string; FBuffer: string;
FLi, FVn, Fmode : byte; FLi, FVn, Fmode : byte;
@ -86,8 +103,6 @@ type
property NTPDelay: Double read FNTPDelay; property NTPDelay: Double read FNTPDelay;
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
property SyncTime: Boolean read FSyncTime write FSyncTime; property SyncTime: Boolean read FSyncTime write FSyncTime;
property SntpHost: string read FSntpHost write FSntpHost;
property Timeout: Integer read FTimeout write FTimeout;
property Sock: TUDPBlockSocket read FSock; property Sock: TUDPBlockSocket read FSock;
end; end;
@ -99,7 +114,7 @@ begin
FSock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
FSock.CreateSocket; FSock.CreateSocket;
FTimeout := 5000; FTimeout := 5000;
FSntpHost := cLocalhost; FTargetPort := cNtpProtocol;
FMaxSyncDiff := 3600; FMaxSyncDiff := 3600;
FSyncTime := False; FSyncTime := False;
end; end;
@ -158,12 +173,12 @@ var
x: Integer; x: Integer;
begin begin
Result := False; Result := False;
FSock.Bind('0.0.0.0', cNtpProtocol); FSock.Bind(FIPInterface, cAnyPort);
FBuffer := FSock.RecvPacket(FTimeout); FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
begin begin
x := Length(FBuffer); x := Length(FBuffer);
if (SntpHost = '0.0.0.0') or (FSock.GetRemoteSinIP = SntpHost) then if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FTargetHost) then
if x >= SizeOf(NTPReply) then if x >= SizeOf(NTPReply) then
begin begin
NtpPtr := Pointer(FBuffer); NtpPtr := Pointer(FBuffer);
@ -183,7 +198,8 @@ var
x: Integer; x: Integer;
begin begin
Result := False; Result := False;
FSock.Connect(sntphost, cNtpProtocol); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FillChar(q, SizeOf(q), 0); FillChar(q, SizeOf(q), 0);
q.mode := $1B; q.mode := $1B;
FSock.SendBuffer(@q, SizeOf(q)); FSock.SendBuffer(@q, SizeOf(q));
@ -211,7 +227,8 @@ var
t1, t2, t3, t4 : TDateTime; t1, t2, t3, t4 : TDateTime;
begin begin
Result := False; Result := False;
FSock.Connect(sntphost, cNtpProtocol); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FillChar(q, SizeOf(q), 0); FillChar(q, SizeOf(q), 0);
q.mode := $1B; q.mode := $1B;
t1 := GetUTTime; t1 := GetUTTime;

35
synachar.pas

@ -3,15 +3,34 @@
|==============================================================================| |==============================================================================|
| Content: Charset conversion support | | Content: Charset conversion support |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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,2001. |

35
synacode.pas

@ -3,15 +3,34 @@
|==============================================================================| |==============================================================================|
| Content: Coding and decoding support | | Content: Coding and decoding support |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c)2000-2002. |

58
synassl.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 001.004.000 | | Project : Delphree - Synapse | 001.006.000 |
|==============================================================================| |==============================================================================|
| Content: SSL support | | Content: SSL support |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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)2002. | | Portions created by Lukas Gebauer are Copyright (c)2002. |
@ -22,6 +41,11 @@
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{
Special thanks to Gregor Ibic <gregor.ibic@intelicom.si>
(Intelicom d.o.o., http://www.intelicom.si)
for good inspiration about SSL programming.
}
unit SynaSSL; unit SynaSSL;
@ -55,6 +79,8 @@ type
const const
EVP_MAX_MD_SIZE = 16+20; EVP_MAX_MD_SIZE = 16+20;
SSL_ERROR_NONE = 0;
SSL_ERROR_SSL = 1;
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;
@ -62,12 +88,14 @@ const
SSL_OP_NO_SSLv3 = $02000000; SSL_OP_NO_SSLv3 = $02000000;
SSL_OP_NO_TLSv1 = $04000000; SSL_OP_NO_TLSv1 = $04000000;
SSL_OP_ALL = $000FFFFF; SSL_OP_ALL = $000FFFFF;
SSL_VERIFY_NONE = $00;
SSL_VERIFY_PEER = $01;
var var
SSLLibHandle: Integer = 0; SSLLibHandle: Integer = 0;
SSLUtilHandle: Integer = 0; SSLUtilHandle: Integer = 0;
// ssleay.dll // libssl.dll
SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil; SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil;
SslLibraryInit : function:Integer cdecl = nil; SslLibraryInit : function:Integer cdecl = nil;
SslLoadErrorStrings : procedure cdecl = nil; SslLoadErrorStrings : procedure cdecl = nil;
@ -90,8 +118,10 @@ var
SslRead : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil; SslRead : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil;
SslPeek : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil; SslPeek : function(ssl: PSSL; buf: PChar; num: Integer):Integer cdecl = nil;
SslWrite : function(ssl: PSSL; const buf: PChar; num: Integer):Integer cdecl = nil; SslWrite : function(ssl: PSSL; const buf: PChar; num: Integer):Integer cdecl = nil;
SslPending : function(ssl: PSSL):Integer cdecl = nil;
SslGetVersion : function(ssl: PSSL):PChar cdecl = nil; SslGetVersion : function(ssl: PSSL):PChar cdecl = nil;
SslGetPeerCertificate : function(ssl: PSSL):PX509 cdecl = nil; SslGetPeerCertificate : function(ssl: PSSL):PX509 cdecl = nil;
SslCtxSetVerify : procedure(ctx: PSSL_CTX; mode: Integer; arg2: Pointer) cdecl = nil;
// libeay.dll // libeay.dll
SslX509Free : procedure(x: PX509) cdecl = nil; SslX509Free : procedure(x: PX509) cdecl = nil;
@ -101,6 +131,9 @@ var
SslX509NameHash : function(x: PX509_NAME):Cardinal cdecl = nil; SslX509NameHash : function(x: PX509_NAME):Cardinal cdecl = nil;
SslX509Digest : function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer cdecl = nil; SslX509Digest : function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer cdecl = nil;
SslEvpMd5 : function:PEVP_MD cdecl = nil; SslEvpMd5 : function:PEVP_MD cdecl = nil;
ErrErrorString : function(e: integer; buf: PChar): PChar cdecl = nil;
ErrGetError : function: integer cdecl = nil;
ErrClearError : procedure cdecl = nil;
function InitSSLInterface: Boolean; function InitSSLInterface: Boolean;
function DestroySSLInterface: Boolean; function DestroySSLInterface: Boolean;
@ -153,8 +186,10 @@ begin
SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read')); SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read'));
SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek')); SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek'));
SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write')); SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write'));
SslPending := GetProcAddress(SSLLibHandle, PChar('SSL_pending'));
SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate')); SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate'));
SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version')); SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version'));
SslCtxSetVerify := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_verify'));
SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free')); SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free'));
SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline')); SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline'));
@ -163,6 +198,9 @@ begin
SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash')); SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash'));
SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest')); SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest'));
SslEvpMd5 := GetProcAddress(SSLUtilHandle, PChar('EVP_md5')); SslEvpMd5 := GetProcAddress(SSLUtilHandle, PChar('EVP_md5'));
ErrerrorString := GetProcAddress(SSLUtilHandle, PChar('ERR_error_string'));
ErrGetError := GetProcAddress(SSLUtilHandle, PChar('ERR_get_error'));
ErrClearError := GetProcAddress(SSLUtilHandle, PChar('ERR_clear_error'));
Result := True; Result := True;
end; end;

367
synautil.pas

@ -1,17 +1,36 @@
{==============================================================================| {==============================================================================|
| Project : Delphree - Synapse | 002.011.001 | | Project : Delphree - Synapse | 003.002.001 |
|==============================================================================| |==============================================================================|
| Content: support procedures and functions | | Content: support procedures and functions |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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-2002. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
@ -62,6 +81,8 @@ procedure DumpEx(const Buffer, DumpFile: string);
function SeparateLeft(const Value, Delimiter: string): string; function SeparateLeft(const Value, Delimiter: string): string;
function SeparateRight(const Value, Delimiter: string): string; function SeparateRight(const Value, Delimiter: string): string;
function GetParameter(const Value, Parameter: string): string; function GetParameter(const Value, Parameter: string): string;
procedure ParseParameters(Value: string; const Parameters: TStrings);
function IndexByBegin(Value: string; const List: TStrings): integer;
function GetEmailAddr(const Value: string): string; function GetEmailAddr(const Value: string): string;
function GetEmailDesc(Value: string): string; function GetEmailDesc(Value: string): string;
function StrToHex(const Value: string): string; function StrToHex(const Value: string): string;
@ -73,45 +94,22 @@ function StringReplace(Value, Search, Replace: string): string;
function RPosEx(const Sub, Value: string; From: integer): Integer; 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;
function IsBinaryString(const Value: string): Boolean;
function PosCRLF(const Value: string; var Terminator: string): integer;
Procedure StringsTrim(const value: TStrings);
function PosFrom(const SubStr, Value: String; From: integer): integer;
implementation implementation
{==============================================================================} {==============================================================================}
var
SaveDayNames: array[1..7] of string;
SaveMonthNames: array[1..12] of string;
const const
MyDayNames: array[1..7] of string = MyDayNames: array[1..7] of string =
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
MyMonthNames: array[1..12] of string = MyMonthNames: array[1..12] of string =
('Jan', 'Feb', 'Mar', 'Apr', ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'May', 'Jun', 'Jul', 'Aug', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
'Sep', 'Oct', 'Nov', 'Dec');
procedure SaveNames;
var
I: integer;
begin
for I := Low(ShortDayNames) to High(ShortDayNames) do
begin
SaveDayNames[I] := ShortDayNames[I];
ShortDayNames[I] := MyDayNames[I];
end;
for I := Low(ShortMonthNames) to High(ShortMonthNames) do
begin
SaveMonthNames[I] := ShortMonthNames[I];
ShortMonthNames[I] := MyMonthNames[I];
end;
end;
procedure RestoreNames;
var
I: integer;
begin
for I := Low(ShortDayNames) to High(ShortDayNames) do
ShortDayNames[I] := SaveDayNames[I];
for I := Low(ShortMonthNames) to High(ShortMonthNames) do
ShortMonthNames[I] := SaveMonthNames[I];
end;
{==============================================================================} {==============================================================================}
function TimeZoneBias: integer; function TimeZoneBias: integer;
@ -161,52 +159,41 @@ end;
{==============================================================================} {==============================================================================}
function Rfc822DateTime(t: TDateTime): string; function Rfc822DateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin begin
SaveNames; DecodeDate(t, wYear, wMonth, wDay);
try Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
Result := FormatDateTime('ddd, d mmm yyyy hh:nn:ss', t); MyMonthNames[wMonth], FormatDateTime('yyyy hh:nn:ss', t), TimeZone]);
Result := Result + ' ' + Timezone;
finally
RestoreNames;
end;
end; end;
{==============================================================================} {==============================================================================}
function CDateTime(t: TDateTime): string; function CDateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin begin
SaveNames; DecodeDate(t, wYear, wMonth, wDay);
try Result:= Format('%s %2d %s', [MyMonthNames[wMonth], wDay,
Result := FormatDateTime('mmm dd hh:nn:ss', t); FormatDateTime('hh:nn:ss', t)]);
if Result[5] = '0' then
Result[5] := ' ';
finally
RestoreNames;
end;
end; end;
{==============================================================================} {==============================================================================}
function SimpleDateTime(t: TDateTime): string; function SimpleDateTime(t: TDateTime): string;
begin begin
SaveNames; Result := FormatDateTime('yymmdd hhnnss', t);
try
Result := FormatDateTime('yymmdd hhnnss', t);
finally
RestoreNames;
end;
end; end;
{==============================================================================} {==============================================================================}
function AnsiCDateTime(t: TDateTime): string; function AnsiCDateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin begin
SaveNames; DecodeDate(t, wYear, wMonth, wDay);
try Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[wMonth],
Result := FormatDateTime('ddd mmm d hh:nn:ss yyyy', t); wDay, FormatDateTime('hh:nn:ss yyyy ', t)]);
finally
RestoreNames;
end;
end; end;
{==============================================================================} {==============================================================================}
@ -316,19 +303,17 @@ end;
function GetTimeFromStr(Value: string): TDateTime; function GetTimeFromStr(Value: string): TDateTime;
var var
SaveSeparator: char; x: integer;
begin begin
SaveSeparator := TimeSeparator; x := rpos(':', Value);
if (x > 0) and ((Length(Value) - x) > 2) then
Value := Copy(Value, 1, x + 2);
Value := StringReplace(Value, ':', TimeSeparator);
Result := 0;
try try
TimeSeparator := ':'; Result := StrToTime(Value);
Result := 0; except
try on Exception do ;
Result := StrToTime(Value);
except
on Exception do ;
end;
finally
TimeSeparator := SaveSeparator;
end; end;
end; end;
@ -336,23 +321,27 @@ end;
function GetDateMDYFromStr(Value: string): TDateTime; function GetDateMDYFromStr(Value: string): TDateTime;
var var
SaveSeparator: char; wYear, wMonth, wDay: word;
SaveFormat: string; s: string;
begin begin
SaveSeparator := DateSeparator; Result := 0;
SaveFormat := ShortDateFormat; s := Fetch(Value, '-');
wMonth := StrToIntDef(s, 12);
s := Fetch(Value, '-');
wDay := StrToIntDef(s, 30);
wYear := StrToIntDef(Value, 1899);
if wYear < 1000 then
if (wYear > 99) then
wYear := wYear + 1900
else
if wYear > 50 then
wYear := wYear + 1900
else
wYear := wYear + 2000;
try try
DateSeparator := '-'; Result := EncodeDate(wYear, wMonth, wDay);
ShortDateFormat := 'm-d-y'; except
Result := 0; on Exception do ;
try
Result := StrToDate(Value);
except
on Exception do ;
end;
finally
ShortDateFormat := SaveFormat;
DateSeparator := SaveSeparator;
end; end;
end; end;
@ -362,7 +351,7 @@ function DecodeRfcDateTime(Value: string): TDateTime;
var var
day, month, year: Word; day, month, year: Word;
zone: integer; zone: integer;
x: integer; x, y: integer;
s: string; s: string;
t: TDateTime; t: TDateTime;
begin begin
@ -426,8 +415,14 @@ begin
continue; continue;
end; end;
// month // month
month := GetMonthNumber(s); y := GetMonthNumber(s);
if y > 0 then
month := y;
end; end;
if (month < 1) or (month > 12) then
month := 1;
if (day < 1) or (day > 31) then
day := 1;
Result := Result + Encodedate(year, month, day); Result := Result + Encodedate(year, month, day);
zone := zone - TimeZoneBias; zone := zone - TimeZoneBias;
t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
@ -523,34 +518,36 @@ end;
function IsIP(const Value: string): Boolean; function IsIP(const Value: string): Boolean;
var var
n, x, i: Integer; TempIP: string;
begin
Result := true; function ByteIsOk(const Value: string): Boolean;
if Pos('..',Value) > 0 then var
Result := False x, n: integer;
else
begin begin
i := 0; x := StrToIntDef(Value, -1);
x := 0; Result := (x >= 0) and (x < 256);
for n := 1 to Length(Value) do // X may be in correct range, but value still may not be correct value!
begin // i.e. "$80"
if (Value[n] in ['0'..'9']) then if Result then
i := i +1 for n := 1 to length(Value) do
else if not (Value[n] in ['0'..'9']) then
if (Value[n] in ['.']) then begin
i := 0
else
Result := False; Result := False;
if Value[n] = '.' Break;
then Inc(x); end;
if i > 3 then
result := False;
if result = false then
Break;
end;
if x <> 3 then
Result := False;
end; end;
begin
TempIP := Value;
Result := False;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if ByteIsOk(TempIP) then
Result := True;
end; end;
{==============================================================================} {==============================================================================}
@ -704,6 +701,40 @@ end;
{==============================================================================} {==============================================================================}
procedure ParseParameters(Value: string; const Parameters: TStrings);
var
s: string;
begin
Parameters.Clear;
while Value <> '' do
begin
s := Fetch(Value, ';');
Parameters.Add(s);
end;
end;
{==============================================================================}
function IndexByBegin(Value: string; const List: TStrings): integer;
var
n: integer;
s: string;
begin
Result := -1;
Value := uppercase(Value);
for n := 0 to List.Count -1 do
begin
s := UpperCase(List[n]);
if Pos(Value, s) = 1 then
begin
Result := n;
Break;
end;
end;
end;
{==============================================================================}
function GetEmailAddr(const Value: string): string; function GetEmailAddr(const Value: string): string;
var var
s: string; s: string;
@ -936,4 +967,98 @@ begin
Result := Trim(Result); Result := Trim(Result);
end; end;
{==============================================================================}
function IsBinaryString(const Value: string): Boolean;
var
n: integer;
begin
Result := False;
for n := 1 to Length(Value) do
if Value[n] in [#0..#8, #10..#31] then
begin
Result := True;
Break;
end;
end;
{==============================================================================}
function PosCRLF(const Value: string; var Terminator: string): integer;
var
p1, p2, p3, p4: integer;
const
t1 = #$0d + #$0a;
t2 = #$0a + #$0d;
t3 = #$0d;
t4 = #$0a;
begin
Terminator := '';
p1 := Pos(t1, Value);
p2 := Pos(t2, Value);
p3 := Pos(t3, Value);
p4 := Pos(t4, Value);
if p1 > 0 then
Terminator := t1;
Result := p1;
if (p2 > 0) then
if (Result = 0) or (p2 < Result) then
begin
Result := p2;
Terminator := t2;
end;
if (p3 > 0) then
if (Result = 0) or (p3 < Result) then
begin
Result := p3;
Terminator := t3;
end;
if (p4 > 0) then
if (Result = 0) or (p4 < Result) then
begin
Result := p4;
Terminator := t4;
end;
end;
{==============================================================================}
Procedure StringsTrim(const Value: TStrings);
var
n: integer;
begin
for n := Value.Count - 1 downto 0 do
if Value[n] = '' then
Value.Delete(n)
else
Break;
end;
{==============================================================================}
function PosFrom(const SubStr, Value: String; From: integer): integer;
var
ls,lv: integer;
begin
Result := 0;
ls := Length(SubStr);
lv := Length(Value);
if (ls = 0) or (lv = 0) then
Exit;
if From < 1 then
From := 1;
while (ls + from - 1) <= (lv) do
begin
if CompareMem(@SubStr[1],@Value[from],ls) then
begin
result := from;
break;
end
else
inc(from);
end;
end;
{==============================================================================}
end. end.

35
synsock.pas

@ -3,15 +3,34 @@
|==============================================================================| |==============================================================================|
| Content: Socket Independent Platform Layer | | Content: Socket Independent Platform Layer |
|==============================================================================| |==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 | | Copyright (c)1999-2002, Lukas Gebauer |
| (the "License"); you may not use this file except in compliance with the | | All rights reserved. |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| | | |
| Software distributed under the License is distributed on an "AS IS" basis, | | Redistribution and use in source and binary forms, with or without |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for | | modification, are permitted provided that the following conditions are met: |
| the specific language governing rights and limitations under the License. | | |
|==============================================================================| | Redistributions of source code must retain the above copyright notice, this |
| The Original Code is Synapse Delphi Library. | | list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================| |==============================================================================|
| 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. |