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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
asn1util.pas
View File

@ -3,15 +3,34 @@
|==============================================================================|
| Content: support for ASN.1 BER coding and decoding |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. |

319
blcksock.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 005.007.000 |
| Project : Delphree - Synapse | 006.001.004 |
|==============================================================================|
| Content: Library base |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)1999-2002. |
@ -22,6 +41,11 @@
| History: see HISTORY.HTM from distribution package |
| (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-}
{$WEAKPACKAGEUNIT ON}
@ -41,6 +65,9 @@ uses
const
cLocalhost = 'localhost';
cAnyHost = '0.0.0.0';
cBroadcast = '255.255.255.255';
cAnyPort = '0';
type
@ -75,12 +102,16 @@ type
FLocalSin: TSockAddrIn;
FRemoteSin: TSockAddrIn;
FLastError: Integer;
FLastErrorDesc: string;
FBuffer: string;
FRaiseExcept: Boolean;
FNonBlockMode: Boolean;
FMaxLineLength: Integer;
FMaxBandwidth: Integer;
FMaxSendBandwidth: Integer;
FNextSend: Cardinal;
FMaxRecvBandwidth: Integer;
FNextRecv: Cardinal;
FConvertLineEnd: Boolean;
function GetSizeRecvBuffer: Integer;
procedure SetSizeRecvBuffer(Size: Integer);
function GetSizeSendBuffer: Integer;
@ -95,7 +126,8 @@ type
function GetSinIP(Sin: TSockAddrIn): string;
function GetSinPort(Sin: TSockAddrIn): Integer;
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
constructor Create;
constructor CreateAlternate(Stub: string);
@ -115,7 +147,7 @@ type
function RecvPacket(Timeout: Integer): string; virtual;
function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual;
function PeekByte(Timeout: Integer): Byte; virtual;
function WaitingData: Integer;
function WaitingData: Integer; virtual;
function WaitingDataEx: Integer;
procedure SetLinger(Enable: Boolean; Linger: Integer);
procedure GetSins;
@ -150,6 +182,7 @@ type
class function GetErrorDesc(ErrorCode: Integer): string;
property Socket: TSocket read FSocket write FSocket;
property LastError: Integer read FLastError;
property LastErrorDesc: string read FLastErrorDesc;
property Protocol: Integer read FProtocol;
property LineBuffer: string read FBuffer write FBuffer;
property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept;
@ -159,7 +192,10 @@ type
property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode;
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;
TSocksBlockSocket = class(TBlockSocket)
@ -207,6 +243,9 @@ type
FSSLCertificateFile: string;
FSSLPrivateKeyFile: string;
FSSLCertCAFile: string;
FSSLLastError: integer;
FSSLLastErrorDesc: string;
FSSLverifyCert: Boolean;
FHTTPTunnelIP: string;
FHTTPTunnelPort: string;
FHTTPTunnel: Boolean;
@ -223,6 +262,7 @@ type
destructor Destroy; override;
procedure CreateSocket; override;
procedure CloseSocket; override;
function WaitingData: Integer; override;
procedure Listen;
function Accept: TSocket;
procedure Connect(IP, Port: string); override;
@ -241,6 +281,7 @@ type
function SSLGetPeerSubjectHash: Cardinal;
function SSLGetPeerIssuerHash: Cardinal;
function SSLGetPeerFingerprint: string;
function SSLCheck: Boolean;
published
property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled;
property SSLBypass: Boolean read FSslBypass write FSslBypass;
@ -249,6 +290,9 @@ type
property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile;
property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile;
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 HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort;
property HTTPTunnel: Boolean read FHTTPTunnel;
@ -299,6 +343,21 @@ type
Options: DWORD;
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
type
@ -318,8 +377,11 @@ begin
FBuffer := '';
FNonBlockMode := False;
FMaxLineLength := 0;
FMaxBandwidth := 0;
FMaxSendBandwidth := 0;
FNextSend := 0;
FMaxRecvBandwidth := 0;
FNextRecv := 0;
FConvertLineEnd := False;
if not InitSocketInterface('') then
begin
e := ESynapseError.Create('Error loading Winsock DLL!');
@ -378,7 +440,7 @@ begin
Sin.sin_port := synsock.htons(StrToIntDef(Port, 0))
else
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)
else
begin
@ -472,27 +534,33 @@ begin
synsock.GetPeerName(FSocket, FremoteSin, Len);
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
x: Cardinal;
y: integer;
y: Cardinal;
begin
if FMaxBandwidth > 0 then
if MaxB > 0 then
begin
y:= GetTick;
if FNextSend > y then
y := GetTick;
if Next > y then
begin
x:= FNextSend - y;
x := Next - y;
if x > 0 then
sleep(x);
end;
FNextSend:= y + Trunc((Length / FMaxBandwidth) * 1000);
Next := y + Trunc((Length / MaxB) * 1000);
end;
end;
function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer;
begin
LimitBandwidth(Length);
LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
Result := synsock.Send(FSocket, Buffer^, Length, 0);
SockCheck(Result);
ExceptCheck;
@ -511,6 +579,7 @@ end;
function TBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer;
begin
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
Result := synsock.Recv(FSocket, Buffer^, Length, 0);
if Result = 0 then
FLastError := WSAECONNRESET
@ -602,7 +671,8 @@ begin
begin
SetLength(Result, x);
x := RecvBuffer(Pointer(Result), x);
SetLength(Result, x);
if x >= 0 then
SetLength(Result, x);
end;
end
else
@ -634,31 +704,57 @@ var
x: Integer;
s: string;
l: Integer;
CorCRLF: Boolean;
t: string;
tl: integer;
begin
FLastError := 0;
Result := '';
l := system.Length(Terminator);
if l = 0 then
Exit;
tl := l;
CorCRLF := FConvertLineEnd and (Terminator = #$0d + #$0a);
// if FBuffer contains requested data, return it...
if FBuffer<>'' then
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
begin
Result := copy(FBuffer, 1, x - 1);
System.Delete(FBuffer, 1, x + l - 1);
exit;
System.Delete(FBuffer, 1, x + tl - 1);
Exit;
end;
end;
// now FBuffer is empty or not contains all data...
s := '';
x := 0;
repeat
//get rest of FBuffer or incomming new data...
s := s + RecvPacket(Timeout);
if FLastError <> 0 then
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
begin
FLastError := WSAENOBUFS;
@ -668,7 +764,7 @@ begin
if x > 0 then
begin
Result := Copy(s, 1, x - 1);
System.Delete(s, 1, x + l - 1);
System.Delete(s, 1, x + tl - 1);
end;
FBuffer := s;
ExceptCheck;
@ -710,8 +806,12 @@ end;
function TBlockSocket.SockCheck(SockResult: Integer): Integer;
begin
if SockResult = SOCKET_ERROR then
Result := synsock.WSAGetLastError
FLastErrorDesc := '';
if SockResult = integer(SOCKET_ERROR) then
begin
Result := synsock.WSAGetLastError;
FLastErrorDesc := GetErrorDesc(Result);
end
else
Result := 0;
FLastError := Result;
@ -931,7 +1031,7 @@ function TBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer;
var
Len: Integer;
begin
LimitBandwidth(Length);
LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
Len := SizeOf(FRemoteSin);
Result := synsock.SendTo(FSocket, Buffer^, Length, 0, FRemoteSin, Len);
SockCheck(Result);
@ -943,6 +1043,7 @@ function TBlockSocket.RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer;
var
Len: Integer;
begin
LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
Len := SizeOf(FRemoteSin);
Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, FRemoteSin, Len);
SockCheck(Result);
@ -1256,7 +1357,6 @@ function TSocksBlockSocket.SocksRequest(Cmd: Byte;
var
Buf: string;
begin
Result := False;
FBypassFlag := True;
try
Buf := #5 + char(Cmd) + #0 + SocksCode(IP, Port);
@ -1330,9 +1430,9 @@ begin
y := Ord(Value[5]);
if Length(Value) < (5 + y + 2) then
Exit;
for n := 6 to 6 + y do
for n := 6 to 6 + y - 1 do
FSocksResponseIP := FSocksResponseIP + Value[n];
Result := 5 + y +1;
Result := 5 + y + 1;
end;
else
Exit;
@ -1498,11 +1598,10 @@ begin
Password := '';
if TTCPBlockSocket(userdata) is TTCPBlockSocket then
Password := TTCPBlockSocket(userdata).SSLPassword;
FillChar(buf, Size, 0);
if Length(Password) > (Size - 1) then
SetLength(Password, Size - 1);
StrPCopy(buf, Password);
Result := Length(Password);
StrLCopy(buf, PChar(Password + #0), Result + 1);
end;
constructor TTCPBlockSocket.Create;
@ -1516,6 +1615,9 @@ begin
FSSLPassword := '';
FSsl := nil;
Fctx := nil;
FSSLLastError := 0;
FSSLLastErrorDesc := '';
FSSLverifyCert := False;
FHTTPTunnelIP := '';
FHTTPTunnelPort := '';
FHTTPTunnel := False;
@ -1545,6 +1647,15 @@ begin
inherited CloseSocket;
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;
var
b: Boolean;
@ -1677,10 +1788,14 @@ begin
FLastError := 0;
if not FSSLEnabled then
SSLEnabled := True;
if sslsetfd(FSsl, FSocket) < 0 then
FLastError := WSASYSNOTREADY;
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;
ExceptCheck;
end;
@ -1732,46 +1847,114 @@ begin
Result := inherited GetRemoteSinPort;
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;
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;
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;
procedure TTCPBlockSocket.SetSslEnabled(Value: Boolean);
var
err: Boolean;
begin
FLastError := 0;
if Value <> FSslEnabled then
if Value then
begin
FBuffer := '';
FSSLLastErrorDesc := '';
FSSLLastError := 0;
if InitSSLInterface then
begin
SslLibraryInit;
SslLoadErrorStrings;
err := False;
Fctx := nil;
Fctx := SslCtxNew(SslMethodV23);
SslCtxSetCipherList(Fctx, PChar(FSSLCiphers));
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
SetSSLKeys;
Fssl := nil;
Fssl := SslNew(Fctx);
FSslEnabled := True;
if Fctx = nil then
begin
SSLCheck;
FlastError := WSAEPROTONOSUPPORT;
err := True;
end
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
else DestroySSLInterface;
else
begin
DestroySSLInterface;
FlastError := WSAEPROTONOSUPPORT;
end;
end
else
begin
FBuffer := '';
sslfree(Fssl);
SslCtxFree(Fctx);
DestroySSLInterface;
FSslEnabled := False;
end;
ExceptCheck;
end;
function TTCPBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer;
@ -1784,7 +1967,7 @@ begin
repeat
Result := SslRead(FSsl, Buffer, Length);
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
Result := 0
else
@ -1807,7 +1990,7 @@ begin
repeat
Result := SslWrite(FSsl, Buffer, Length);
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
Result := 0
else
@ -1822,14 +2005,17 @@ end;
function TTCPBlockSocket.SSLAcceptConnection: Boolean;
begin
Result := False;
FLastError := 0;
if not FSSLEnabled then
SSLEnabled := True;
if sslsetfd(FSsl, FSocket) < 0 then
FLastError := WSASYSNOTREADY;
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;
ExceptCheck;
Result := FLastError = 0;
@ -1914,4 +2100,15 @@ begin
inherited CreateSocket;
end;
{======================================================================}
constructor TSynaClient.Create;
begin
inherited Create;
FIPInterface := cAnyHost;
FTargetHost := cLocalhost;
FTargetPort := cAnyPort;
FTimeout := 5000;
end;
end.

50
dnssend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.001.004 |
| Project : Delphree - Synapse | 001.002.000 |
|==============================================================================|
| Content: DNS client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |
@ -81,10 +100,8 @@ const
QTYPE_ALL = 255; //
type
TDNSSend = class(TObject)
TDNSSend = class(TSynaClient)
private
FTimeout: Integer;
FDNSHost: string;
FRCode: Integer;
FBuffer: string;
FSock: TUDPBlockSocket;
@ -100,8 +117,6 @@ type
function DNSQuery(Name: string; QType: Integer;
const Reply: TStrings): Boolean;
published
property Timeout: Integer read FTimeout Write FTimeout;
property DNSHost: string read FDNSHost Write FDNSHost;
property RCode: Integer read FRCode;
property Sock: TUDPBlockSocket read FSock;
end;
@ -117,7 +132,7 @@ begin
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 5000;
FDNSHost := cLocalhost;
FTargetPort := cDnsProtocol;
end;
destructor TDNSSend.Destroy;
@ -290,7 +305,8 @@ begin
if IsIP(Name) then
Name := ReverseIP(Name) + '.in-addr.arpa';
FBuffer := CodeHeader + CodeQuery(Name, QType);
FSock.Connect(FDNSHost, cDnsProtocol);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if (FSock.LastError = 0) and (Length(FBuffer) > 13) then
@ -337,7 +353,7 @@ begin
t := TStringList.Create;
DNS := TDNSSend.Create;
try
DNS.DNSHost := DNSHost;
DNS.TargetHost := DNSHost;
if DNS.DNSQuery(Domain, QType_MX, t) then
begin
{ normalize preference number to 5 digits }

240
ftpsend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.000.000 |
| Project : Delphree - Synapse | 002.003.001 |
|==============================================================================|
| Content: FTP client |
|==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
@ -68,14 +87,11 @@ type
property List: TList read FList;
end;
TFTPSend = class(TObject)
TFTPSend = class(TSynaClient)
private
FOnStatus: TFTPStatus;
FSock: TTCPBlockSocket;
FDSock: TTCPBlockSocket;
FTimeout: Integer;
FFTPHost: string;
FFTPPort: string;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
@ -114,6 +130,7 @@ type
function FTPCommand(const Value: string): integer;
function Login: Boolean;
procedure Logout;
procedure Abort;
function List(Directory: string; NameList: Boolean): Boolean;
function RetriveFile(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 GetCurrentDir: String;
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 ResultString: string read FResultString;
property FullResult: TStringList read FFullResult;
@ -179,8 +193,7 @@ begin
FDSock := TTCPBlockSocket.Create;
FFtpList := TFTPList.Create;
FTimeout := 300000;
FFTPHost := cLocalhost;
FFTPPort := cFtpProtocol;
FTargetPort := cFtpProtocol;
FUsername := 'anonymous';
FPassword := 'anonymous@' + FSock.LocalName;
FDirectFile := False;
@ -285,10 +298,10 @@ begin
Result := False;
if FFWHost = '' then
Mode := 0;
if (FFTPPort = cFtpProtocol) or (FFTPPort = '21') then
FTPServer := FFTPHost
if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then
FTPServer := FTargetHost
else
FTPServer := FFTPHost + ':' + FFTPPort;
FTPServer := FTargetHost + ':' + FTargetPort;
case Mode of
-1:
LogonActions := CustomLogon;
@ -349,8 +362,9 @@ function TFTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FFWHost = '' then
FSock.Connect(FFTPHost, FFTPPort)
FSock.Connect(FTargetHost, FTargetPort)
else
FSock.Connect(FFWHost, FFWPort);
Result := FSock.LastError = 0;
@ -362,7 +376,7 @@ begin
FCanResume := False;
if not Connect then
Exit;
if ReadResult <> 220 then
if (ReadResult div 100) <> 2 then
Exit;
if not Auth(FFWMode) then
Exit;
@ -420,11 +434,12 @@ begin
Result := False;
if FPassiveMode then
begin
if FTPCommand('PASV') <> 227 then
if (FTPCommand('PASV') div 100) <> 2 then
Exit;
ParseRemote(FResultString);
FDSock.CloseSocket;
FDSock.CreateSocket;
FSock.Bind(FIPInterface, cAnyPort);
FDSock.Connect(FDataIP, FDataPort);
Result := FDSock.LastError = 0;
end
@ -436,7 +451,11 @@ begin
s := cFtpDataProtocol
else
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
Exit;
FDSock.Listen;
@ -447,7 +466,7 @@ begin
s := StringReplace(FDataIP, '.', ',');
s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256)
+ ',' + IntToStr(FDSock.GetLocalSinPort mod 256);
Result := FTPCommand(s) = 200;
Result := (FTPCommand(s) div 100) = 2;
end;
end;
@ -485,9 +504,9 @@ begin
if FDSock.LastError = 0 then
DestStream.Write(Pointer(buf)^, Length(buf));
until FDSock.LastError <> 0;
FDSock.CloseSocket;
x := ReadResult;
if (x = 226) or (x = 250) then
Result := True;
Result := (x div 100) = 2;
finally
FDSock.CloseSocket;
end;
@ -524,8 +543,7 @@ begin
Exit;
FDSock.CloseSocket;
x := ReadResult;
if (x = 226) or (x = 250) then
Result := True;
Result := (x div 100) = 2;
finally
FDSock.CloseSocket;
end;
@ -577,7 +595,7 @@ begin
if FDirectFile then
if Restore and FileExists(FDirectFileName) then
RetrStream := TFileStream.Create(FDirectFileName,
fmOpenReadWrite or fmShareExclusive)
fmOpenReadWrite or fmShareExclusive)
else
RetrStream := TFileStream.Create(FDirectFileName,
fmCreate or fmShareDenyWrite)
@ -590,7 +608,7 @@ begin
if Restore then
begin
RetrStream.Seek(0, soFromEnd);
if FTPCommand('REST ' + IntToStr(RetrStream.Size)) <> 350 then
if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then
Exit;
end
else
@ -637,7 +655,7 @@ begin
RestoreAt := 0;
FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt));
if FCanResume then
if FTPCommand('REST ' + IntToStr(RestoreAt)) <> 350 then
if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then
Exit;
SendStream.Seek(RestoreAt, soFromBeginning);
if (FTPCommand(Command) div 100) <> 1 then
@ -688,14 +706,14 @@ end;
function TFTPSend.RenameFile(const OldName, NewName: string): Boolean;
begin
Result := False;
if FTPCommand('RNFR ' + OldName) <> 350 then
if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then
Exit;
Result := FTPCommand('RNTO ' + NewName) = 250;
Result := (FTPCommand('RNTO ' + NewName) div 100) = 2;
end;
function TFTPSend.DeleteFile(const FileName: string): Boolean;
begin
Result := FTPCommand('DELE ' + FileName) = 250;
Result := (FTPCommand('DELE ' + FileName) div 100) = 2;
end;
function TFTPSend.FileSize(const FileName: string): integer;
@ -703,7 +721,7 @@ var
s: string;
begin
Result := -1;
if FTPCommand('SIZE ' + FileName) = 213 then
if (FTPCommand('SIZE ' + FileName) div 100) = 2 then
begin
s := SeparateRight(ResultString, ' ');
s := SeparateLeft(s, ' ');
@ -713,28 +731,28 @@ end;
function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean;
begin
Result := FTPCommand('CWD ' + Directory) = 250;
Result := (FTPCommand('CWD ' + Directory) div 100) = 2;
end;
function TFTPSend.ChangeToRootDir: Boolean;
begin
Result := FTPCommand('CDUP') = 200;
Result := (FTPCommand('CDUP') div 100) = 2;
end;
function TFTPSend.DeleteDir(const Directory: string): Boolean;
begin
Result := FTPCommand('RMD ' + Directory) = 250;
Result := (FTPCommand('RMD ' + Directory) div 100) = 2;
end;
function TFTPSend.CreateDir(const Directory: string): Boolean;
begin
Result := FTPCommand('MKD ' + Directory) = 257;
Result := (FTPCommand('MKD ' + Directory) div 100) = 2;
end;
function TFTPSend.GetCurrentDir: String;
begin
Result := '';
if FTPCommand('PWD') = 257 then
if (FTPCommand('PWD') div 100) = 2 then
begin
Result := SeparateRight(FResultString, '"');
Result := Separateleft(Result, '"');
@ -767,6 +785,7 @@ begin
end;
// 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;
var
flr: TFTPListRec;
@ -777,10 +796,12 @@ var
mday: Word;
t: TDateTime;
x: integer;
al_tmp : array[1..2] of string; // alex
begin
Result := False;
if Length(Value) < 2 then
Exit;
year := 0;
month := 0;
mday := 0;
@ -853,68 +874,69 @@ begin
(Value[1] = 's') or
(Value[1] = '-') then
begin
if Value[1] = 'd' then
flr.Directory := True;
if Value[1] = '-' then
flr.Readable := True;
if Value[1] = 'l' then
// alex begin
// default year
DecodeDate(date,year,month,mday); // alex
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
flr.Directory := True;
flr.Readable := True;
end;
state := 1;
state:=1;
s := Fetch(Value, ' ');
while s <> '' do
while s<>'' do
begin
case state of
1:
begin
state := 2;
if (s[1] = 'f') and (Pos(' ', s) = 6) then
state := 3;
end;
2:
state := 3;
3:
begin
flr.FileSize := StrToIntDef(s, 0);
state := 4;
end;
4:
begin
month := GetMonthNumber(s);
if month > 0 then
state := 5
else
flr.FileSize := StrToIntDef(s, 0);
end;
5:
begin
mday := StrToIntDef(s, 0);
state := 6;
end;
6:
begin
if (Pos(':', s) > 0) then
t := GetTimeFromStr(s)
else
if Length(s) = 4 then
year := StrToIntDef(s, 0)
else Exit;
if (year = 0) or (month = 0) or (mday = 0) then
Exit;
flr.FileTime := t + Encodedate(year, month, mday);
state := 7;
end;
7:
begin
flr.FileName := s;
Result := True;
end;
end;
s := Fetch(Value, ' ');
month:=GetMonthNumber(s);
if month>0 then
break;
al_tmp[state]:=s;
if state=1 then state:=2
else state:=1;
s := Fetch(Value, ' ');
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;
{Microsoft NT 4.0 FTP Service
10-20-98 08:57AM 619098 rizrem.zip
@ -947,8 +969,7 @@ begin
end;
if Value = '' then
Exit;
s := Fetch(Value, ' ');
flr.FileName := s;
flr.FileName := Trim(s);
Result := True;
Exit;
end;
@ -1015,8 +1036,8 @@ begin
Username := User;
Password := Pass;
end;
FTPHost := IP;
FTPPort := Port;
TargetHost := IP;
TargetPort := Port;
if not Login then
Exit;
DirectFileName := LocalFile;
@ -1039,8 +1060,8 @@ begin
Username := User;
Password := Pass;
end;
FTPHost := IP;
FTPPort := Port;
TargetHost := IP;
TargetPort := Port;
if not Login then
Exit;
DirectFileName := LocalFile;
@ -1074,10 +1095,10 @@ begin
ToFTP.Username := ToUser;
ToFTP.Password := ToPass;
end;
FromFTP.FTPHost := FromIP;
FromFTP.FTPPort := FromPort;
ToFTP.FTPHost := ToIP;
ToFTP.FTPPort := ToPort;
FromFTP.TargetHost := FromIP;
FromFTP.TargetPort := FromPort;
ToFTP.TargetHost := ToIP;
ToFTP.TargetPort := ToPort;
if not FromFTP.Login then
Exit;
if not ToFTP.Login then
@ -1111,4 +1132,9 @@ begin
end;
end;
procedure TFTPSend.Abort;
begin
FDSock.CloseSocket;
end;
end.

84
httpsend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.000.003 |
| Project : Delphree - Synapse | 003.002.000 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
@ -39,7 +58,7 @@ const
type
TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
THTTPSend = class(TObject)
THTTPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FTransferEncoding: TTransferEncoding;
@ -50,9 +69,6 @@ type
FMimeType: string;
FProtocol: string;
FKeepAlive: Boolean;
FTimeout: Integer;
FHTTPHost: string;
FHTTPPort: string;
FProxyHost: string;
FProxyPort: string;
FProxyUser: string;
@ -74,9 +90,6 @@ type
property MimeType: string read FMimeType Write FMimeType;
property Protocol: string read FProtocol Write FProtocol;
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 ProxyPort: string read FProxyPort Write FProxyPort;
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 HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStringList): Boolean;
const Data: TStream; const ResultData: TStrings): Boolean;
implementation
@ -106,9 +119,9 @@ begin
FSock := TTCPBlockSocket.Create;
FSock.SizeRecvBuffer := 65536;
FSock.SizeSendBuffer := 65536;
FSock.ConvertLineEnd := True;
FTimeout := 300000;
FHTTPHost := cLocalhost;
FHTTPPort := cHttpProtocol;
FTargetPort := cHttpProtocol;
FProxyHost := '';
FProxyPort := '8080';
FProxyUser := '';
@ -155,7 +168,6 @@ var
ToClose: Boolean;
Size: Integer;
Prot, User, Pass, Host, Port, Path, Para, URI: string;
n: Integer;
s, su: string;
HttpTunnel: Boolean;
begin
@ -219,27 +231,30 @@ begin
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
if (FProxyHost <> '') and not(HttpTunnel) then
begin
FHTTPHost := FProxyHost;
FHTTPPort := FProxyPort;
FTargetHost := FProxyHost;
FTargetPort := FProxyPort;
end
else
begin
FHTTPHost := Host;
FHTTPPort := Port;
FTargetHost := Host;
FTargetPort := Port;
end;
if FHeaders[FHeaders.Count - 1] <> '' then
FHeaders.Add('');
{ connect }
if (FAliveHost <> FHTTPHost) or (FAlivePort <> FHTTPPort) then
if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort) then
begin
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Connect(FHTTPHost, FHTTPPort);
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError <> 0 then
Exit;
FAliveHost := FHTTPHost;
FAlivePort := FHTTPPort;
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError <> 0 then
Exit;
FAliveHost := FTargetHost;
FAlivePort := FTargetPort;
end
else
begin
@ -247,7 +262,10 @@ begin
begin
FSock.CloseSocket;
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
Exit;
end;
@ -257,7 +275,11 @@ begin
if FProtocol = '0.9' then
FSock.SendString(FHeaders[0] + CRLF)
else
{$IFDEF LINUX}
FSock.SendString(AdjustLineBreaks(FHeaders.Text, tlbsCRLF));
{$ELSE}
FSock.SendString(FHeaders.Text);
{$ENDIF}
if FSock.LastError <> 0 then
Exit;
@ -320,7 +342,7 @@ begin
else
FHeaders.Add(Status100Error);
{ if need receive hedaers, receive and parse it }
{ if need receive headers, receive and parse it }
ToClose := FProtocol <> '1.1';
if FHeaders.Count > 0 then
repeat
@ -479,7 +501,7 @@ begin
end;
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStringList): Boolean;
const Data: TStream; const ResultData: TStrings): Boolean;
const
CRLF = #$0D + #$0A;
var

54
imapsend.pas
View File

@ -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 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2002. |
@ -40,12 +59,9 @@ const
cIMAPProtocol = '143';
type
TIMAPSend = class(TObject)
TIMAPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FTimeout: Integer;
FIMAPHost: string;
FIMAPPort: string;
FTagCommand: integer;
FResultString: string;
FFullResult: TStringList;
@ -101,9 +117,6 @@ type
function StartTLS: Boolean;
function FindCap(const Value: string): string;
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 FullResult: TStringList read FFullResult;
property IMAPcap: TStringList read FIMAPcap;
@ -134,9 +147,9 @@ begin
FSock.CreateSocket;
FSock.SizeRecvBuffer := 32768;
FSock.SizeSendBuffer := 32768;
FSock.ConvertLineEnd := True;
FTimeout := 300000;
FIMAPhost := cLocalhost;
FIMAPPort := cIMAPProtocol;
FTargetPort := cIMAPProtocol;
FUsername := '';
FPassword := '';
FTagCommand := 0;
@ -316,7 +329,8 @@ begin
FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(FIMAPHost, FIMAPPort);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0;
end;

35
mimeinln.pas
View File

@ -3,15 +3,34 @@
|==============================================================================|
| Content: Inline MIME support procedures and functions |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |

332
mimemess.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.007.004 |
| Project : Delphree - Synapse | 002.001.001 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2002. |
@ -48,10 +67,10 @@ type
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure EncodeHeaders(const Value: TStringList);
procedure DecodeHeaders(const Value: TStringList);
procedure EncodeHeaders(const Value: TStrings);
procedure DecodeHeaders(const Value: TStrings);
function FindHeader(Value: string): string;
procedure FindHeaderList(Value: string; const HeaderList: TStringList);
procedure FindHeaderList(Value: string; const HeaderList: TStrings);
published
property From: string read FFrom Write FFrom;
property ToList: TStringList read FToList;
@ -65,28 +84,29 @@ type
TMimeMess = class(TObject)
private
FPartList: TList;
FMessagePart: TMimePart;
FLines: TStringList;
FHeader: TMessHeader;
FMultipartType: string;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function AddPart: Integer;
procedure AddPartText(const Value: TStringList);
procedure AddPartHTML(const Value: TStringList);
procedure AddPartHTMLBinary(Value, Cid: string);
procedure AddPartBinary(Value: string);
function AddPart(const PartParent: TMimePart): TMimePart;
function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
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 FinalizeHeaders;
procedure ParseHeaders;
procedure DecodeMessage;
published
property PartList: TList read FPartList;
property MessagePart: TMimePart read FMessagePart;
property Lines: TStringList read FLines;
property Header: TMessHeader read FHeader;
property MultipartType: string read FMultipartType Write FMultipartType;
end;
implementation
@ -123,7 +143,7 @@ begin
FXMailer := '';
end;
procedure TMessHeader.EncodeHeaders(const Value: TStringList);
procedure TMessHeader.EncodeHeaders(const Value: TStrings);
var
n: Integer;
s: string;
@ -162,7 +182,7 @@ begin
Value.Insert(0, 'From: ' + InlineEmail(FFrom));
end;
procedure TMessHeader.DecodeHeaders(const Value: TStringList);
procedure TMessHeader.DecodeHeaders(const Value: TStrings);
var
s, t: string;
x: Integer;
@ -250,7 +270,7 @@ begin
end;
end;
procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStringList);
procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
var
n: integer;
begin
@ -267,47 +287,58 @@ end;
constructor TMimeMess.Create;
begin
inherited Create;
FPartList := TList.Create;
FMessagePart := TMimePart.Create;
FLines := TStringList.Create;
FHeader := TMessHeader.Create;
FMultipartType := 'Mixed';
end;
destructor TMimeMess.Destroy;
begin
Clear;
FMessagePart.Free;
FHeader.Free;
Lines.Free;
PartList.Free;
FLines.Free;
inherited Destroy;
end;
{==============================================================================}
procedure TMimeMess.Clear;
var
n: Integer;
begin
FMultipartType := 'Mixed';
Lines.Clear;
for n := 0 to FPartList.Count - 1 do
TMimePart(FPartList[n]).Free;
FPartList.Clear;
FMessagePart.Clear;
FLines.Clear;
FHeader.Clear;
end;
{==============================================================================}
function TMimeMess.AddPart: Integer;
function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
begin
Result := FPartList.Add(TMimePart.Create);
if PartParent = nil then
Result := FMessagePart
else
Result := PartParent.AddSubPart;
Result.Clear;
end;
{==============================================================================}
procedure TMimeMess.AddPartText(const Value: TStringList);
function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
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
Value.SaveToStream(DecodedLines);
Primary := 'text';
@ -319,14 +350,14 @@ begin
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
EncodePartHeader;
end;
end;
{==============================================================================}
procedure TMimeMess.AddPartHTML(const Value: TStringList);
function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
begin
with TMimePart(FPartList[AddPart]) do
Result := AddPart(PartParent);
with Result do
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
@ -336,43 +367,86 @@ begin
CharsetCode := UTF_8;
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
EncodePartHeader;
end;
end;
{==============================================================================}
procedure TMimeMess.AddPartBinary(Value: string);
function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
s: string;
tmp: TStrings;
begin
with TMimePart(FPartList[AddPart]) do
begin
DecodedLines.LoadFromFile(Value);
s := ExtractFileName(Value);
MimeTypeFromExt(s);
Description := 'Attached file: ' + s;
Disposition := 'attachment';
FileName := s;
EncodingCode := ME_BASE64;
EncodePart;
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartText(tmp, PartParent);
Finally
tmp.Free;
end;
end;
procedure TMimeMess.AddPartHTMLBinary(Value, Cid: string);
function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
s: string;
tmp: TStrings;
begin
with TMimePart(FPartList[AddPart]) do
begin
DecodedLines.LoadFromFile(Value);
s := ExtractFileName(Value);
MimeTypeFromExt(s);
Description := 'Included file: ' + s;
Disposition := 'inline';
ContentID := Cid;
FileName := s;
EncodingCode := ME_BASE64;
EncodePart;
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartHTML(tmp, PartParent);
Finally
tmp.Free;
end;
end;
function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
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;
@ -380,96 +454,44 @@ end;
procedure TMimeMess.EncodeMessage;
var
bound: string;
n: Integer;
m:TMimepart;
l: TStringList;
x: integer;
begin
FLines.Clear;
if FPartList.Count = 1 then
begin
TMimePart(FPartList[0]).EncodePart;
FLines.Assign(TMimePart(FPartList[0]).Lines)
end
else
begin
bound := GenerateBoundary;
for n := 0 to FPartList.Count - 1 do
begin
FLines.Add('--' + bound);
TMimePart(FPartList[n]).EncodePart;
FLines.AddStrings(TMimePart(FPartList[n]).Lines);
end;
FLines.Add('--' + bound + '--');
m := TMimePart.Create;
try
FLines.SaveToStream(m.DecodedLines);
m.Primary := 'Multipart';
m.Secondary := FMultipartType;
m.Description := 'Multipart message';
m.Boundary := bound;
m.EncodePart;
FLines.Assign(m.Lines);
finally
m.Free;
end;
//merge headers from THeaders and header field from MessagePart
l := TStringList.Create;
try
FHeader.EncodeHeaders(l);
x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
FMessagePart.Headers.Assign(l);
finally
l.Free;
end;
end;
{==============================================================================}
procedure TMimeMess.FinalizeHeaders;
begin
FHeader.EncodeHeaders(FLines);
end;
{==============================================================================}
procedure TMimeMess.ParseHeaders;
begin
FHeader.DecodeHeaders(FLines);
FMessagePart.ComposeParts;
FLines.Assign(FMessagePart.Lines);
end;
{==============================================================================}
procedure TMimeMess.DecodeMessage;
var
l: TStringList;
m: TMimePart;
i: Integer;
bound: string;
begin
l := TStringList.Create;
m := TMimePart.Create;
try
l.Assign(FLines);
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;
FHeader.Clear;
FHeader.DecodeHeaders(FLines);
FMessagePart.Lines.Assign(FLines);
FMessagePart.DecomposeParts;
end;
end.

721
mimepart.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.008.004 |
| Project : Delphree - Synapse | 002.001.002 |
|==============================================================================|
| Content: MIME support procedures and functions |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2002. |
@ -29,10 +48,16 @@ interface
uses
SysUtils, Classes,
{$IFNDEF LINUX}
Windows,
{$ENDIF}
SynaChar, SynaCode, SynaUtil, MIMEinLn;
type
TMimePart = class;
THookWalkPart = procedure(const Sender: TMimePart) of object;
TMimePrimary = (MP_TEXT, MP_MULTIPART,
MP_MESSAGE, MP_BINARY);
@ -42,22 +67,28 @@ type
TMimePart = class(TObject)
private
FPrimary: string;
FEncoding: string;
FCharset: string;
FDefaultCharset: string;
FPrimaryCode: TMimePrimary;
FSecondary: string;
FEncoding: string;
FEncodingCode: TMimeEncoding;
FDefaultCharset: string;
FCharset: string;
FCharsetCode: TMimeChar;
FTargetCharset: TMimeChar;
FSecondary: string;
FDescription: string;
FDisposition: string;
FContentID: string;
FBoundary: string;
FFileName: string;
FLines: TStringList;
FPartBody: TStringList;
FHeaders: TStringList;
FPrePart: TStringList;
FPostPart: TStringList;
FDecodedLines: TMemoryStream;
FSkipLast: Boolean;
FSubParts: TList;
FOnWalkPart: THookWalkPart;
FMaxLineLength: integer;
procedure SetPrimary(Value: string);
procedure SetEncoding(Value: string);
procedure SetCharset(Value: string);
@ -65,10 +96,18 @@ type
constructor Create;
destructor Destroy; override;
procedure Clear;
function ExtractPart(Value: TStringList; BeginLine: Integer): Integer;
procedure DecodePart;
procedure DecodePartHeader;
procedure EncodePart;
procedure EncodePartHeader;
procedure MimeTypeFromExt(Value: string);
function GetSubPartCount: integer;
function GetSubPart(index: integer): TMimePart;
procedure ClearSubParts;
function AddSubPart: TMimePart;
procedure DecomposeParts;
procedure ComposeParts;
procedure WalkPart;
published
property Primary: string read FPrimary write SetPrimary;
property Encoding: string read FEncoding write SetEncoding;
@ -85,8 +124,13 @@ type
property Boundary: string read FBoundary Write FBoundary;
property FileName: string read FFileName Write FFileName;
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 SkipLast: Boolean read FSkipLast Write FSkipLast;
property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart;
property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength;
end;
const
@ -121,12 +165,12 @@ const
('ZIP', 'application', 'ZIP')
);
function NormalizeHeader(Value: TStringList; var Index: Integer): string;
function NormalizeHeader(Value: TStrings; var Index: Integer): string;
function GenerateBoundary: string;
implementation
function NormalizeHeader(Value: TStringList; var Index: Integer): string;
function NormalizeHeader(Value: TStrings; var Index: Integer): string;
var
s, t: string;
n: Integer;
@ -150,7 +194,7 @@ begin
Inc(Index);
end;
end;
Result := s;
Result := TrimRight(s);
end;
{==============================================================================}
@ -158,17 +202,29 @@ end;
constructor TMIMEPart.Create;
begin
inherited Create;
FOnWalkPart := nil;
FLines := TStringList.Create;
FPartBody := TStringList.Create;
FHeaders := TStringList.Create;
FPrePart := TStringList.Create;
FPostPart := TStringList.Create;
FDecodedLines := TMemoryStream.Create;
FSubParts := TList.Create;
FTargetCharset := GetCurCP;
FDefaultCharset := 'US-ASCII';
FSkipLast := True;
FMaxLineLength := 78;
end;
destructor TMIMEPart.Destroy;
begin
ClearSubParts;
FSubParts.Free;
FDecodedLines.Free;
FPartBody.Free;
FLines.Free;
FHeaders.Free;
FPrePart.Free;
FPostPart.Free;
inherited Destroy;
end;
@ -189,51 +245,316 @@ begin
FDescription := '';
FBoundary := '';
FFileName := '';
FLines.Clear;
FPartBody.Clear;
FHeaders.Clear;
FPrePart.Clear;
FPostPart.Clear;
FDecodedLines.Clear;
ClearSubParts;
end;
{==============================================================================}
function TMIMEPart.ExtractPart(Value: TStringList; BeginLine: Integer): Integer;
var
n, x, x1, x2: Integer;
t: TStringList;
s, su, b: string;
st, st2: string;
e: Boolean;
fn: string;
function TMIMEPart.GetSubPartCount: integer;
begin
t := TStringlist.Create;
try
{ defaults }
FLines.Clear;
Primary := 'text';
FSecondary := 'plain';
FDescription := '';
Charset := FDefaultCharset;
FFileName := '';
Encoding := '7BIT';
Result := FSubParts.Count;
end;
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 }
while Value.Count > x do
function TMIMEPart.GetSubPart(index: integer): TMimePart;
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
s := NormalizeHeader(Value, x);
if s = '' then
s := TrimRight(FLines[x]);
if s <> '' then
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);
if Pos('CONTENT-TYPE:', su) = 1 then
begin
@ -271,141 +592,10 @@ begin
if Pos('CONTENT-ID:', su) = 1 then
FContentID := SeparateRight(s, ':');
end;
if (PrimaryCode = MP_BINARY) and (FFileName = '') then
FFileName := fn;
FFileName := InlineDecode(FFileName, getCurCP);
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);
if (PrimaryCode = MP_BINARY) and (FFileName = '') then
FFileName := fn;
FFileName := InlineDecode(FFileName, getCurCP);
FFileName := ExtractFileName(FFileName);
end;
{==============================================================================}
@ -416,18 +606,16 @@ var
s, t: string;
n, x: Integer;
d1, d2: integer;
const
MaxLine = 75;
begin
if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
Encoding := 'base64';
l := TStringList.Create;
FLines.Clear;
FPartBody.Clear;
FDecodedLines.Seek(0, soFromBeginning);
try
case FPrimaryCode of
MP_MULTIPART, MP_MESSAGE:
FLines.LoadFromStream(FDecodedLines);
FPartBody.LoadFromStream(FDecodedLines);
MP_TEXT, MP_BINARY:
if FEncodingCode = ME_BASE64 then
begin
@ -439,7 +627,7 @@ begin
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FTargetCharset, FCharsetCode);
s := EncodeBase64(s);
FLines.Add(s);
FPartBody.Add(s);
end;
end
else
@ -454,85 +642,37 @@ begin
begin
s := EncodeQuotedPrintable(s);
repeat
if Length(s) < MaxLine then
if Length(s) < FMaxLineLength then
begin
t := s;
s := '';
end
else
begin
d1 := RPosEx('=', s, MaxLine);
d2 := RPosEx(' ', s, MaxLine);
d1 := RPosEx('=', s, FMaxLineLength);
d2 := RPosEx(' ', s, FMaxLineLength);
if (d1 = 0) and (d2 = 0) then
x := MaxLine
x := FMaxLineLength
else
if d1 > d2 then
x := d1 - 1
else
x := d2 - 1;
if x = 0 then
x := FMaxLineLength;
t := Copy(s, 1, x);
s := Copy(s, x + 1, Length(s) - x);
if s <> '' then
t := t + '=';
end;
FLines.Add(t);
FPartBody.Add(t);
until s = '';
end
else
FLines.Add(s);
FPartBody.Add(s);
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
l.Free;
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);
var
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);
var
s: string;
@ -612,9 +828,10 @@ function GenerateBoundary: string;
var
x: Integer;
begin
Sleep(1);
Randomize;
x := Random(MaxInt);
Result := '--' + IntToHex(x, 8) + '_Synapse_message_boundary';
Result := IntToHex(x, 8) + '_Synapse_message_boundary';
end;
end.

54
nntpsend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.000 |
| Project : Delphree - Synapse | 001.001.000 |
|==============================================================================|
| Content: NNTP client |
|==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001. |
@ -37,12 +56,9 @@ const
cNNTPProtocol = 'nntp';
type
TNNTPSend = class(TObject)
TNNTPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FTimeout: Integer;
FNNTPHost: string;
FNNTPPort: string;
FResultCode: Integer;
FResultString: string;
FData: TStringList;
@ -69,9 +85,6 @@ type
function PostArticle: Boolean;
function SwitchToSlave: Boolean;
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 ResultString: string read FResultString;
property Data: TStringList read FData;
@ -89,9 +102,9 @@ begin
FData := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FTimeout := 300000;
FNNTPhost := cLocalhost;
FNNTPPort := cNNTPProtocol;
FTargetPort := cNNTPProtocol;
end;
destructor TNNTPSend.Destroy;
@ -120,7 +133,6 @@ function TNNTPSend.ReadData: boolean;
var
s: string;
begin
Result := False;
repeat
s := FSock.RecvString(FTimeout);
if s = '.' then
@ -137,7 +149,6 @@ var
s: string;
n: integer;
begin
Result := False;
for n := 0 to FData.Count -1 do
begin
s := FData[n];
@ -154,7 +165,8 @@ function TNNTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Connect(FNNTPHost, FNNTPPort);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0;
end;

44
pingsend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.002.000 |
| Project : Delphree - Synapse | 002.003.001 |
|==============================================================================|
| Content: PING sender |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |
@ -59,13 +78,12 @@ type
TimeStamp: ULONG;
end;
TPINGSend = class(TObject)
TPINGSend = class(TSynaClient)
private
FSock: TICMPBlockSocket;
FBuffer: string;
FSeq: Integer;
FId: Integer;
FTimeout: Integer;
FPacketSize: Integer;
FPingTime: Integer;
function Checksum: Integer;
@ -75,7 +93,6 @@ type
constructor Create;
destructor Destroy; override;
published
property Timeout: Integer read FTimeout Write FTimeout;
property PacketSize: Integer read FPacketSize Write FPacketSize;
property PingTime: Integer read FPingTime;
property Sock: TICMPBlockSocket read FSock;
@ -119,6 +136,7 @@ var
t: Boolean;
begin
Result := False;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(Host, '0');
FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize);
IcmpEchoHeaderPtr := Pointer(FBuffer);
@ -144,7 +162,7 @@ begin
IPHeadPtr := Pointer(FBuffer);
IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
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...
if t then
if (IcmpEchoHeaderPtr^.i_type = ICMP_ECHOREPLY) then

52
pop3send.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.000.000 |
| Project : Delphree - Synapse | 002.001.000 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2002. |
@ -45,12 +64,9 @@ const
type
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
TPOP3Send = class(TObject)
TPOP3Send = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FTimeout: Integer;
FPOP3Host: string;
FPOP3Port: string;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
@ -84,9 +100,6 @@ type
function StartTLS: Boolean;
function FindCap(const Value: string): string;
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 ResultString: string read FResultString;
property FullResult: TStringList read FFullResult;
@ -113,9 +126,9 @@ begin
FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FTimeout := 300000;
FPOP3host := cLocalhost;
FPOP3Port := cPop3Protocol;
FTargetPort := cPop3Protocol;
FUsername := '';
FPassword := '';
FStatCount := 0;
@ -182,7 +195,8 @@ begin
FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(POP3Host, POP3Port);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0;
end;

55
slogsend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.001 |
| Project : Delphree - Synapse | 001.001.000 |
|==============================================================================|
| Content: SysLog client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2001. |
@ -68,10 +87,8 @@ type
TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
Debug);
TSyslogSend = class(TObject)
TSyslogSend = class(TSynaClient)
private
FSyslogHost: string;
FSyslogPort: string;
FSock: TUDPBlockSocket;
FFacility: Byte;
FSeverity: TSyslogSeverity;
@ -82,8 +99,6 @@ type
destructor Destroy; override;
function DoIt: Boolean;
published
property SyslogHost: string read FSyslogHost Write FSyslogHost;
property SyslogPort: string read FSyslogPort Write FSyslogPort;
property Facility: Byte read FFacility Write FFacility;
property Severity: TSyslogSeverity read FSeverity Write FSeverity;
property Tag: string read FTag Write FTag;
@ -100,12 +115,12 @@ begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FSyslogHost := cLocalhost;
FSyslogPort := cSysLogProtocol;
FTargetPort := cSysLogProtocol;
FFacility := FCL_Local0;
FSeverity := Debug;
FTag := ExtractFileName(ParamStr(0));
FMessage := '';
FIPInterface := cAnyHost;
end;
destructor TSyslogSend.Destroy;
@ -138,8 +153,10 @@ begin
if Length(Buf) <= 1024 then
begin
if FSock.EnableReuse(True) then
Fsock.Bind('0.0.0.0', FSyslogPort);
FSock.Connect(FSyslogHost, FSyslogPort);
Fsock.Bind(FIPInterface, FTargetPort)
else
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(Buf);
Result := FSock.LastError = 0;
end;
@ -153,7 +170,7 @@ begin
Result := False;
with TSyslogSend.Create do
try
SyslogHost :=SyslogServer;
TargetHost :=SyslogServer;
Facility := Facil;
Severity := Sever;
LogMessage := Content;

58
smtpsend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.001.000 |
| Project : Delphree - Synapse | 003.002.001 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2002. |
@ -37,12 +56,9 @@ const
cSmtpProtocol = 'smtp';
type
TSMTPSend = class(TObject)
TSMTPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FTimeout: Integer;
FSMTPHost: string;
FSMTPPort: string;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
@ -82,9 +98,6 @@ type
function EnhCodeString: string;
function FindCap(const Value: string): string;
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 ResultString: string read FResultString;
property FullResult: TStringList read FFullResult;
@ -123,9 +136,9 @@ begin
FESMTPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FTimeout := 300000;
FSMTPhost := cLocalhost;
FSMTPPort := cSmtpProtocol;
FTargetPort := cSmtpProtocol;
FUsername := '';
FPassword := '';
FSystemName := FSock.LocalName;
@ -232,7 +245,8 @@ begin
FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Connect(FSMTPHost, FSMTPPort);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0;
end;
@ -302,8 +316,6 @@ begin
if (Pos('LOGIN', auths) > 0) and (not FauthDone) then
FAuthDone := AuthLogin;
end;
if FAuthDone then
Ehlo;
end;
s := FindCap('SIZE');
if s <> '' then
@ -498,10 +510,10 @@ begin
// SMTP.AutoTLS := True;
// if you need support for TSL/SSL tunnel, uncomment next lines:
// SMTP.FullSSL := True;
SMTP.SMTPHost := SeparateLeft(SMTPHost, ':');
SMTP.TargetHost := SeparateLeft(SMTPHost, ':');
s := SeparateRight(SMTPHost, ':');
if (s <> '') and (s <> SMTPHost) then
SMTP.SMTPPort := s;
SMTP.TargetPort := s;
SMTP.Username := Username;
SMTP.Password := Password;
if SMTP.Login then

128
snmpsend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.003.006 |
| Project : Delphree - Synapse | 002.005.000 |
|==============================================================================|
| Content: SNMP client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |
@ -93,12 +112,10 @@ type
property SNMPMibList: TList read FSNMPMibList;
end;
TSNMPSend = class(TObject)
TSNMPSend = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FBuffer: string;
FTimeout: Integer;
FHost: string;
FHostIP: string;
FQuery: TSNMPRec;
FReply: TSNMPRec;
@ -107,8 +124,6 @@ type
destructor Destroy; override;
function DoIt: Boolean;
published
property Timeout: Integer read FTimeout write FTimeout;
property Host: string read FHost write FHost;
property HostIP: string read FHostIP;
property Query: TSNMPRec read FQuery;
property Reply: TSNMPRec read FReply;
@ -117,6 +132,9 @@ type
function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): 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
@ -278,7 +296,7 @@ begin
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 5000;
FHost := cLocalhost;
FTargetPort := cSnmpProtocol;
FHostIP := '';
end;
@ -294,8 +312,9 @@ function TSNMPSend.DoIt: Boolean;
begin
FReply.Clear;
FBuffer := FQuery.EncodeBuf;
FSock.Connect(FHost, cSnmpProtocol);
FHostIP := '0.0.0.0';
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FHostIP := cAnyHost;
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
@ -319,12 +338,11 @@ begin
SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUGetRequest;
SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
SNMPSend.Host := SNMPHost;
SNMPSend.TargetHost := SNMPHost;
Result := SNMPSend.DoIt;
Value := '';
if Result then
Value := SNMPSend.Reply.MIBGet(OID)
else
Value := '';
Value := SNMPSend.Reply.MIBGet(OID);
finally
SNMPSend.Free;
end;
@ -340,13 +358,79 @@ begin
SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUSetRequest;
SNMPSend.Query.MIBAdd(OID, Value, ValueType);
SNMPSend.Host := SNMPHost;
SNMPSend.TargetHost := SNMPHost;
Result := SNMPSend.DoIt = True;
finally
SNMPSend.Free;
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.

62
snmptrap.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.002.004 |
| Project : Delphree - Synapse | 002.003.000 |
|==============================================================================|
| Content: SNMP traps |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Hernan Sanchez are Copyright (c)2000,2001. |
@ -50,7 +69,6 @@ type
TTrapPDU = class(TObject)
private
FBuffer: string;
FTrapPort: string;
FVersion: Integer;
FPDUType: Integer;
FCommunity: string;
@ -73,7 +91,6 @@ type
property Version: Integer read FVersion Write FVersion;
property Community: string read FCommunity Write FCommunity;
property PDUType: Integer read FPDUType Write FPDUType;
property TrapPort: string read FTrapPort Write FTrapPort;
property Enterprise: string read FEnterprise Write FEnterprise;
property TrapHost: string read FTrapHost Write FTrapHost;
property GenTrap: Integer read FGenTrap Write FGenTrap;
@ -82,12 +99,10 @@ type
property SNMPMibList: TList read FSNMPMibList;
end;
TTrapSNMP = class(TObject)
TTrapSNMP = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FTrap: TTrapPDU;
FSNMPHost: string;
FTimeout: Integer;
public
constructor Create;
destructor Destroy; override;
@ -95,8 +110,6 @@ type
function Recv: Integer;
published
property Trap: TTrapPDU read FTrap;
property SNMPHost: string read FSNMPHost Write FSNMPHost;
property Timeout: Integer read FTimeout Write FTimeout;
property Sock: TUDPBlockSocket read FSock;
end;
@ -113,7 +126,6 @@ constructor TTrapPDU.Create;
begin
inherited Create;
FSNMPMibList := TList.Create;
FTrapPort := cSnmpTrapProtocol;
FVersion := SNMP_VERSION;
FPDUType := PDU_TRAP;
FCommunity := 'public';
@ -136,7 +148,6 @@ begin
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Clear;
FTrapPort := cSnmpTrapProtocol;
FVersion := SNMP_VERSION;
FPDUType := PDU_TRAP;
FCommunity := 'public';
@ -261,10 +272,10 @@ constructor TTrapSNMP.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTrap := TTrapPDU.Create;
FTimeout := 5000;
FSNMPHost := cLocalhost;
FSock.CreateSocket;
FTargetPort := cSnmpTrapProtocol;
end;
destructor TTrapSNMP.Destroy;
@ -277,7 +288,8 @@ end;
function TTrapSNMP.Send: Integer;
begin
FTrap.EncodeTrap;
FSock.Connect(SNMPHost, FTrap.TrapPort);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FTrap.FBuffer);
Result := 1;
end;
@ -285,7 +297,7 @@ end;
function TTrapSNMP.Recv: Integer;
begin
Result := 0;
FSock.Bind('0.0.0.0', FTrap.TrapPort);
FSock.Bind(FIPInterface, FTargetPort);
FTrap.FBuffer := FSock.RecvPacket(FTimeout);
if Fsock.Lasterror = 0 then
if FTrap.DecodeTrap then
@ -298,7 +310,7 @@ function SendTrap(const Dest, Source, Enterprise, Community: string;
begin
with TTrapSNMP.Create do
try
SNMPHost := Dest;
TargetHost := Dest;
Trap.TrapHost := Source;
Trap.Enterprise := Enterprise;
Trap.Community := Community;
@ -320,11 +332,11 @@ var
begin
with TTrapSNMP.Create do
try
SNMPHost := Dest;
TargetHost := Dest;
Result := Recv;
if Result <> 0 then
begin
Dest := SNMPHost;
Dest := TargetHost;
Source := Trap.TrapHost;
Enterprise := Trap.Enterprise;
Community := Trap.Community;

55
sntpsend.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.000 |
| Project : Delphree - Synapse | 002.002.000 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |
@ -58,7 +77,7 @@ type
Xmit2: Longint;
end;
TSNTPSend = class(TObject)
TSNTPSend = class(TSynaClient)
private
FNTPReply: TNtp;
FNTPTime: TDateTime;
@ -66,8 +85,6 @@ type
FNTPDelay: double;
FMaxSyncDiff: double;
FSyncTime: Boolean;
FSntpHost: string;
FTimeout: Integer;
FSock: TUDPBlockSocket;
FBuffer: string;
FLi, FVn, Fmode : byte;
@ -86,8 +103,6 @@ type
property NTPDelay: Double read FNTPDelay;
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
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;
end;
@ -99,7 +114,7 @@ begin
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 5000;
FSntpHost := cLocalhost;
FTargetPort := cNtpProtocol;
FMaxSyncDiff := 3600;
FSyncTime := False;
end;
@ -158,12 +173,12 @@ var
x: Integer;
begin
Result := False;
FSock.Bind('0.0.0.0', cNtpProtocol);
FSock.Bind(FIPInterface, cAnyPort);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
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
begin
NtpPtr := Pointer(FBuffer);
@ -183,7 +198,8 @@ var
x: Integer;
begin
Result := False;
FSock.Connect(sntphost, cNtpProtocol);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FillChar(q, SizeOf(q), 0);
q.mode := $1B;
FSock.SendBuffer(@q, SizeOf(q));
@ -211,7 +227,8 @@ var
t1, t2, t3, t4 : TDateTime;
begin
Result := False;
FSock.Connect(sntphost, cNtpProtocol);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FillChar(q, SizeOf(q), 0);
q.mode := $1B;
t1 := GetUTTime;

35
synachar.pas
View File

@ -3,15 +3,34 @@
|==============================================================================|
| Content: Charset conversion support |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |

35
synacode.pas
View File

@ -3,15 +3,34 @@
|==============================================================================|
| Content: Coding and decoding support |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2002. |

58
synassl.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.004.000 |
| Project : Delphree - Synapse | 001.006.000 |
|==============================================================================|
| Content: SSL support |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2002. |
@ -22,6 +41,11 @@
| History: see HISTORY.HTM from distribution package |
| (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;
@ -55,6 +79,8 @@ type
const
EVP_MAX_MD_SIZE = 16+20;
SSL_ERROR_NONE = 0;
SSL_ERROR_SSL = 1;
SSL_ERROR_WANT_READ = 2;
SSL_ERROR_WANT_WRITE = 3;
SSL_ERROR_ZERO_RETURN = 6;
@ -62,12 +88,14 @@ const
SSL_OP_NO_SSLv3 = $02000000;
SSL_OP_NO_TLSv1 = $04000000;
SSL_OP_ALL = $000FFFFF;
SSL_VERIFY_NONE = $00;
SSL_VERIFY_PEER = $01;
var
SSLLibHandle: Integer = 0;
SSLUtilHandle: Integer = 0;
// ssleay.dll
// libssl.dll
SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil;
SslLibraryInit : function:Integer cdecl = nil;
SslLoadErrorStrings : procedure cdecl = nil;
@ -90,8 +118,10 @@ var
SslRead : 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;
SslPending : function(ssl: PSSL):Integer cdecl = nil;
SslGetVersion : function(ssl: PSSL):PChar cdecl = nil;
SslGetPeerCertificate : function(ssl: PSSL):PX509 cdecl = nil;
SslCtxSetVerify : procedure(ctx: PSSL_CTX; mode: Integer; arg2: Pointer) cdecl = nil;
// libeay.dll
SslX509Free : procedure(x: PX509) cdecl = nil;
@ -101,6 +131,9 @@ var
SslX509NameHash : function(x: PX509_NAME):Cardinal cdecl = nil;
SslX509Digest : function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer 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 DestroySSLInterface: Boolean;
@ -153,8 +186,10 @@ begin
SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read'));
SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek'));
SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write'));
SslPending := GetProcAddress(SSLLibHandle, PChar('SSL_pending'));
SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate'));
SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version'));
SslCtxSetVerify := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_verify'));
SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free'));
SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline'));
@ -163,6 +198,9 @@ begin
SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash'));
SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest'));
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;
end;

367
synautil.pas
View File

@ -1,17 +1,36 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.011.001 |
| Project : Delphree - Synapse | 003.002.001 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| 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 SeparateRight(const Value, Delimiter: 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 GetEmailDesc(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 RPos(const Sub, Value: String): Integer;
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
{==============================================================================}
var
SaveDayNames: array[1..7] of string;
SaveMonthNames: array[1..12] of string;
const
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 =
('Jan', 'Feb', 'Mar', 'Apr',
'May', 'Jun', 'Jul', 'Aug',
'Sep', 'Oct', 'Nov', 'Dec');
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', '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;
@ -161,52 +159,41 @@ end;
{==============================================================================}
function Rfc822DateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin
SaveNames;
try
Result := FormatDateTime('ddd, d mmm yyyy hh:nn:ss', t);
Result := Result + ' ' + Timezone;
finally
RestoreNames;
end;
DecodeDate(t, wYear, wMonth, wDay);
Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
MyMonthNames[wMonth], FormatDateTime('yyyy hh:nn:ss', t), TimeZone]);
end;
{==============================================================================}
function CDateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin
SaveNames;
try
Result := FormatDateTime('mmm dd hh:nn:ss', t);
if Result[5] = '0' then
Result[5] := ' ';
finally
RestoreNames;
end;
DecodeDate(t, wYear, wMonth, wDay);
Result:= Format('%s %2d %s', [MyMonthNames[wMonth], wDay,
FormatDateTime('hh:nn:ss', t)]);
end;
{==============================================================================}
function SimpleDateTime(t: TDateTime): string;
begin
SaveNames;
try
Result := FormatDateTime('yymmdd hhnnss', t);
finally
RestoreNames;
end;
Result := FormatDateTime('yymmdd hhnnss', t);
end;
{==============================================================================}
function AnsiCDateTime(t: TDateTime): string;
var
wYear, wMonth, wDay: word;
begin
SaveNames;
try
Result := FormatDateTime('ddd mmm d hh:nn:ss yyyy', t);
finally
RestoreNames;
end;
DecodeDate(t, wYear, wMonth, wDay);
Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[wMonth],
wDay, FormatDateTime('hh:nn:ss yyyy ', t)]);
end;
{==============================================================================}
@ -316,19 +303,17 @@ end;
function GetTimeFromStr(Value: string): TDateTime;
var
SaveSeparator: char;
x: integer;
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
TimeSeparator := ':';
Result := 0;
try
Result := StrToTime(Value);
except
on Exception do ;
end;
finally
TimeSeparator := SaveSeparator;
Result := StrToTime(Value);
except
on Exception do ;
end;
end;
@ -336,23 +321,27 @@ end;
function GetDateMDYFromStr(Value: string): TDateTime;
var
SaveSeparator: char;
SaveFormat: string;
wYear, wMonth, wDay: word;
s: string;
begin
SaveSeparator := DateSeparator;
SaveFormat := ShortDateFormat;
Result := 0;
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
DateSeparator := '-';
ShortDateFormat := 'm-d-y';
Result := 0;
try
Result := StrToDate(Value);
except
on Exception do ;
end;
finally
ShortDateFormat := SaveFormat;
DateSeparator := SaveSeparator;
Result := EncodeDate(wYear, wMonth, wDay);
except
on Exception do ;
end;
end;
@ -362,7 +351,7 @@ function DecodeRfcDateTime(Value: string): TDateTime;
var
day, month, year: Word;
zone: integer;
x: integer;
x, y: integer;
s: string;
t: TDateTime;
begin
@ -426,8 +415,14 @@ begin
continue;
end;
// month
month := GetMonthNumber(s);
y := GetMonthNumber(s);
if y > 0 then
month := y;
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);
zone := zone - TimeZoneBias;
t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
@ -523,34 +518,36 @@ end;
function IsIP(const Value: string): Boolean;
var
n, x, i: Integer;
begin
Result := true;
if Pos('..',Value) > 0 then
Result := False
else
TempIP: string;
function ByteIsOk(const Value: string): Boolean;
var
x, n: integer;
begin
i := 0;
x := 0;
for n := 1 to Length(Value) do
begin
if (Value[n] in ['0'..'9']) then
i := i +1
else
if (Value[n] in ['.']) then
i := 0
else
x := StrToIntDef(Value, -1);
Result := (x >= 0) and (x < 256);
// X may be in correct range, but value still may not be correct value!
// i.e. "$80"
if Result then
for n := 1 to length(Value) do
if not (Value[n] in ['0'..'9']) then
begin
Result := False;
if Value[n] = '.'
then Inc(x);
if i > 3 then
result := False;
if result = false then
Break;
end;
if x <> 3 then
Result := False;
Break;
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;
{==============================================================================}
@ -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;
var
s: string;
@ -936,4 +967,98 @@ begin
Result := Trim(Result);
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.

35
synsock.pas
View File

@ -3,15 +3,34 @@
|==============================================================================|
| Content: Socket Independent Platform Layer |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| Copyright (c)1999-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| 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).|
| Portions created by Lukas Gebauer are Copyright (c)2001. |