pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 38

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@82 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:42:16 +00:00
parent 316ed093f8
commit 5925414eaa
27 changed files with 2799 additions and 922 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

211
blcksock.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 009.001.003 | | Project : Ararat Synapse | 009.004.001 |
|==============================================================================| |==============================================================================|
| Content: Library base | | Content: Library base |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)1999-2006. | | Portions created by Lukas Gebauer are Copyright (c)1999-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -99,7 +99,7 @@ uses
const const
SynapseRelease = '37'; SynapseRelease = '38';
cLocalhost = '127.0.0.1'; cLocalhost = '127.0.0.1';
cAnyHost = '0.0.0.0'; cAnyHost = '0.0.0.0';
@ -188,6 +188,15 @@ type
THookMonitor = procedure(Sender: TObject; Writing: Boolean; THookMonitor = procedure(Sender: TObject; Writing: Boolean;
const Buffer: TMemory; Len: Integer) of object; const Buffer: TMemory; Len: Integer) of object;
{:This procedural type is used for hook OnAfterConnect. By this hook you can
insert your code after TCP socket has been sucessfully connected.}
THookAfterConnect = procedure(Sender: TObject) of object;
{:This procedural type is used for hook OnHeartbeat. By this hook you can
call your code repeately during long socket operations.
You must enable heartbeats by @Link(HeartbeatRate) property!}
THookHeartbeat = procedure(Sender: TObject) of object;
{:Specify family of socket.} {:Specify family of socket.}
TSocketFamily = ( TSocketFamily = (
{:Default mode. Socket family is defined by target address for connection. {:Default mode. Socket family is defined by target address for connection.
@ -254,6 +263,7 @@ type
FOnReadFilter: THookDataFilter; FOnReadFilter: THookDataFilter;
FOnCreateSocket: THookCreateSocket; FOnCreateSocket: THookCreateSocket;
FOnMonitor: THookMonitor; FOnMonitor: THookMonitor;
FOnHeartbeat: THookHeartbeat;
FLocalSin: TVarSin; FLocalSin: TVarSin;
FRemoteSin: TVarSin; FRemoteSin: TVarSin;
FTag: integer; FTag: integer;
@ -282,6 +292,8 @@ type
FSendCounter: Integer; FSendCounter: Integer;
FSendMaxChunk: Integer; FSendMaxChunk: Integer;
FStopFlag: Boolean; FStopFlag: Boolean;
FNonblockSendTimeout: Integer;
FHeartbeatRate: integer;
function GetSizeRecvBuffer: Integer; function GetSizeRecvBuffer: Integer;
procedure SetSizeRecvBuffer(Size: Integer); procedure SetSizeRecvBuffer(Size: Integer);
function GetSizeSendBuffer: Integer; function GetSizeSendBuffer: Integer;
@ -308,10 +320,12 @@ type
procedure DoReadFilter(Buffer: TMemory; var Len: Integer); procedure DoReadFilter(Buffer: TMemory; var Len: Integer);
procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
procedure DoCreateSocket; procedure DoCreateSocket;
procedure DoHeartbeat;
procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
procedure SetBandwidth(Value: Integer); procedure SetBandwidth(Value: Integer);
function TestStopFlag: Boolean; function TestStopFlag: Boolean;
procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual; procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual;
function InternalCanRead(Timeout: Integer): Boolean; virtual;
public public
constructor Create; constructor Create;
@ -537,10 +551,13 @@ type
{:Actualize values in @link(LocalSin) and @link(RemoteSin).} {:Actualize values in @link(LocalSin) and @link(RemoteSin).}
procedure GetSins; procedure GetSins;
{:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.}
procedure ResetLastError;
{:If you "manually" call Socket API functions, forward their return code as {:If you "manually" call Socket API functions, forward their return code as
parameter to this function, which evaluates it, eventually calls parameter to this function, which evaluates it, eventually calls
GetLastError and found error code returns and stores to @link(LastError).} GetLastError and found error code returns and stores to @link(LastError).}
function SockCheck(SockResult: Integer): Integer; function SockCheck(SockResult: Integer): Integer; virtual;
{:If @link(LastError) contains some error code and @link(RaiseExcept) {:If @link(LastError) contains some error code and @link(RaiseExcept)
property is @true, raise adequate exception.} property is @true, raise adequate exception.}
@ -590,7 +607,8 @@ type
data maybe forever. data maybe forever.
This function is need only on special cases, when you need use This function is need only on special cases, when you need use
@link(RecvBuffer) function directly!} @link(RecvBuffer) function directly! read functioms what have timeout as
calling parameter, calling this function internally.}
function CanRead(Timeout: Integer): Boolean; virtual; function CanRead(Timeout: Integer): Boolean; virtual;
{:Same as @link(CanRead), but additionally return @TRUE if is some data in {:Same as @link(CanRead), but additionally return @TRUE if is some data in
@ -714,6 +732,9 @@ type
You may call it without created object!} You may call it without created object!}
class function GetErrorDesc(ErrorCode: Integer): string; class function GetErrorDesc(ErrorCode: Integer): string;
{:Return descriptive string for @link(LastError).}
function GetErrorDescEx: string; virtual;
{:this value is for free use.} {:this value is for free use.}
property Tag: Integer read FTag write FTag; property Tag: Integer read FTag write FTag;
@ -770,6 +791,9 @@ type
use this property for soft abort of communication.} use this property for soft abort of communication.}
property StopFlag: Boolean read FStopFlag Write FStopFlag; property StopFlag: Boolean read FStopFlag Write FStopFlag;
{:Timeout for data sending by non-blocking socket mode.}
property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout;
{:This event is called by various reasons. It is good for monitoring socket, {:This event is called by various reasons. It is good for monitoring socket,
create gauges for data transfers, etc.} create gauges for data transfers, etc.}
property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
@ -785,6 +809,18 @@ type
{:This event is good for monitoring content of readed or writed datas.} {:This event is good for monitoring content of readed or writed datas.}
property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor; property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor;
{:This event is good for calling your code during long socket operations.
(Example, for refresing UI if class in not called within the thread.)
Rate of heartbeats can be modified by @link(HeartbeatRate) property.}
property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat;
{:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing.
Default value 0 disabling heartbeats! Value is in milliseconds.
Real rate can be higher or smaller then this value, because it depending
on real socket operations too!
Note: Each heartbeat slowing socket processing.}
property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate;
end; end;
{:@abstract(Support for SOCKS4 and SOCKS5 proxy) {:@abstract(Support for SOCKS4 and SOCKS5 proxy)
@ -865,6 +901,7 @@ type
(outgoing connections and limited incomming), TCP through HTTP proxy tunnel.} (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.}
TTCPBlockSocket = class(TSocksBlockSocket) TTCPBlockSocket = class(TSocksBlockSocket)
protected protected
FOnAfterConnect: THookAfterConnect;
FSSL: TCustomSSL; FSSL: TCustomSSL;
FHTTPTunnelIP: string; FHTTPTunnelIP: string;
FHTTPTunnelPort: string; FHTTPTunnelPort: string;
@ -876,6 +913,7 @@ type
FHTTPTunnelTimeout: integer; FHTTPTunnelTimeout: integer;
procedure SocksDoConnect(IP, Port: string); procedure SocksDoConnect(IP, Port: string);
procedure HTTPTunnelDoConnect(IP, Port: string); procedure HTTPTunnelDoConnect(IP, Port: string);
procedure DoAfterConnect;
public public
{:Create TCP socket class with default plugin for SSL/TSL/SSH implementation {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation
(see @link(SSLImplementation))} (see @link(SSLImplementation))}
@ -885,6 +923,10 @@ type
constructor CreateWithSSL(SSLPlugin: TSSLClass); constructor CreateWithSSL(SSLPlugin: TSSLClass);
destructor Destroy; override; destructor Destroy; override;
{:Return descriptive string for @link(LastError). On case of error
in SSL/TLS subsystem, it returns right error description.}
function GetErrorDescEx: string; override;
{:See @link(TBlockSocket.CloseSocket)} {:See @link(TBlockSocket.CloseSocket)}
procedure CloseSocket; override; procedure CloseSocket; override;
@ -994,6 +1036,9 @@ type
{:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.} {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.}
property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout; property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout;
{:This event is called after sucessful TCP socket connection.}
property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect;
end; end;
{:@abstract(Datagram based communication) {:@abstract(Datagram based communication)
@ -1410,6 +1455,8 @@ begin
FSendCounter := 0; FSendCounter := 0;
FSendMaxChunk := c64k; FSendMaxChunk := c64k;
FStopFlag := False; FStopFlag := False;
FNonblockSendTimeout := 15000;
FHeartbeatRate := 0;
{$IFNDEF ONCEWINSOCK} {$IFNDEF ONCEWINSOCK}
if Stub = '' then if Stub = '' then
Stub := DLLStackName; Stub := DLLStackName;
@ -1615,7 +1662,7 @@ var
f: TSocketFamily; f: TSocketFamily;
begin begin
DoStatus(HR_ResolvingBegin, IP + ':' + Port); DoStatus(HR_ResolvingBegin, IP + ':' + Port);
FLastError := 0; ResetLastError;
//if socket exists, then use their type, else use users selection //if socket exists, then use their type, else use users selection
f := SF_Any; f := SF_Any;
if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then
@ -1648,7 +1695,7 @@ var
sin: TVarSin; sin: TVarSin;
begin begin
//dummy for SF_Any Family mode //dummy for SF_Any Family mode
FLastError := 0; ResetLastError;
if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then
begin begin
{$IFDEF CIL} {$IFDEF CIL}
@ -1671,7 +1718,7 @@ procedure TBlockSocket.CreateSocketByName(const Value: String);
var var
sin: TVarSin; sin: TVarSin;
begin begin
FLastError := 0; ResetLastError;
if FSocket = INVALID_SOCKET then if FSocket = INVALID_SOCKET then
begin begin
SetSin(sin, value, '0'); SetSin(sin, value, '0');
@ -1685,7 +1732,7 @@ begin
FStopFlag := False; FStopFlag := False;
FRecvCounter := 0; FRecvCounter := 0;
FSendCounter := 0; FSendCounter := 0;
FLastError := 0; ResetLastError;
if FSocket = INVALID_SOCKET then if FSocket = INVALID_SOCKET then
begin begin
FBuffer := ''; FBuffer := '';
@ -1728,7 +1775,6 @@ begin
end; end;
FDelayedOptions.Clear; FDelayedOptions.Clear;
FFamily := FFamilySave; FFamily := FFamilySave;
FLastError := 0;
DoStatus(HR_SocketClose, ''); DoStatus(HR_SocketClose, '');
end; end;
@ -1736,7 +1782,7 @@ procedure TBlockSocket.Bind(IP, Port: string);
var var
Sin: TVarSin; Sin: TVarSin;
begin begin
FLastError := 0; ResetLastError;
if (FSocket <> INVALID_SOCKET) if (FSocket <> INVALID_SOCKET)
or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then
begin begin
@ -1801,7 +1847,10 @@ procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next:
var var
x: LongWord; x: LongWord;
y: LongWord; y: LongWord;
n: integer;
begin begin
if FStopFlag then
exit;
if MaxB > 0 then if MaxB > 0 then
begin begin
y := GetTick; y := GetTick;
@ -1811,7 +1860,12 @@ begin
if x > 0 then if x > 0 then
begin begin
DoStatus(HR_Wait, IntToStr(x)); DoStatus(HR_Wait, IntToStr(x));
sleep(x); sleep(x mod 250);
for n := 1 to x div 250 do
if FStopFlag then
Break
else
sleep(250);
end; end;
end; end;
Next := GetTick + Trunc((Length / MaxB) * 1000); Next := GetTick + Trunc((Length / MaxB) * 1000);
@ -1820,6 +1874,7 @@ end;
function TBlockSocket.TestStopFlag: Boolean; function TBlockSocket.TestStopFlag: Boolean;
begin begin
DoHeartbeat;
Result := FStopFlag; Result := FStopFlag;
if Result then if Result then
begin begin
@ -1856,10 +1911,19 @@ begin
begin begin
LimitBandwidth(y, FMaxSendBandwidth, FNextsend); LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
p := IncPoint(Buffer, x); p := IncPoint(Buffer, x);
// r := synsock.Send(FSocket, p^, y, MSG_NOSIGNAL);
r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
SockCheck(r); SockCheck(r);
if Flasterror <> 0 then if FLastError = WSAEWOULDBLOCK then
begin
if CanWrite(FNonblockSendTimeout) then
begin
r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
SockCheck(r);
end
else
FLastError := WSAETIMEDOUT;
end;
if FLastError <> 0 then
Break; Break;
Inc(x, r); Inc(x, r);
Inc(Result, r); Inc(Result, r);
@ -2031,7 +2095,7 @@ var
b: TMemory; b: TMemory;
{$ENDIF} {$ENDIF}
begin begin
FLastError := 0; ResetLastError;
Result := 0; Result := 0;
if Len > 0 then if Len > 0 then
begin begin
@ -2109,7 +2173,7 @@ var
{$ENDIF} {$ENDIF}
begin begin
Result := ''; Result := '';
FLastError := 0; ResetLastError;
if FBuffer <> '' then if FBuffer <> '' then
begin begin
Result := FBuffer; Result := FBuffer;
@ -2184,7 +2248,7 @@ end;
function TBlockSocket.RecvByte(Timeout: Integer): Byte; function TBlockSocket.RecvByte(Timeout: Integer): Byte;
begin begin
Result := 0; Result := 0;
FLastError := 0; ResetLastError;
if FBuffer = '' then if FBuffer = '' then
FBuffer := RecvPacket(Timeout); FBuffer := RecvPacket(Timeout);
if (FLastError = 0) and (FBuffer <> '') then if (FLastError = 0) and (FBuffer <> '') then
@ -2215,7 +2279,7 @@ var
tl: integer; tl: integer;
ti: LongWord; ti: LongWord;
begin begin
FLastError := 0; ResetLastError;
Result := ''; Result := '';
l := Length(Terminator); l := Length(Terminator);
if l = 0 then if l = 0 then
@ -2393,24 +2457,28 @@ begin
{$ENDIF} {$ENDIF}
end; end;
procedure TBlockSocket.ResetLastError;
begin
FLastError := 0;
FLastErrorDesc := '';
end;
function TBlockSocket.SockCheck(SockResult: Integer): Integer; function TBlockSocket.SockCheck(SockResult: Integer): Integer;
begin begin
FLastErrorDesc := ''; ResetLastError;
if SockResult = integer(SOCKET_ERROR) then if SockResult = integer(SOCKET_ERROR) then
begin begin
Result := synsock.WSAGetLastError; FLastError := synsock.WSAGetLastError;
FLastErrorDesc := GetErrorDesc(Result); FLastErrorDesc := GetErrorDescEx;
end end;
else Result := FLastError;
Result := 0;
FLastError := Result;
end; end;
procedure TBlockSocket.ExceptCheck; procedure TBlockSocket.ExceptCheck;
var var
e: ESynapseError; e: ESynapseError;
begin begin
FLastErrorDesc := GetErrorDesc(FLastError); FLastErrorDesc := GetErrorDescEx;
if (LastError <> 0) and (LastError <> WSAEINPROGRESS) if (LastError <> 0) and (LastError <> WSAEINPROGRESS)
and (LastError <> WSAEWOULDBLOCK) then and (LastError <> WSAEWOULDBLOCK) then
begin begin
@ -2419,8 +2487,6 @@ begin
begin begin
e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s', e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s',
[FLastError, FLastErrorDesc])); [FLastError, FLastErrorDesc]));
// e := ESynapseError.CreateFmt('Synapse TCP/IP Socket error %d: %s',
// [FLastError, FLastErrorDesc]);
e.ErrorCode := FLastError; e.ErrorCode := FLastError;
e.ErrorMessage := FLastErrorDesc; e.ErrorMessage := FLastErrorDesc;
raise e; raise e;
@ -2460,7 +2526,7 @@ begin
except except
on exception do; on exception do;
end; end;
FLastError := 0; ResetLastError;
end; end;
procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer);
@ -2539,7 +2605,7 @@ begin
Result := GetSinPort(FRemoteSin); Result := GetSinPort(FRemoteSin);
end; end;
function TBlockSocket.CanRead(Timeout: Integer): Boolean; function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean;
{$IFDEF CIL} {$IFDEF CIL}
begin begin
Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead); Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead);
@ -2562,6 +2628,38 @@ begin
x := 0; x := 0;
Result := x > 0; Result := x > 0;
{$ENDIF} {$ENDIF}
end;
function TBlockSocket.CanRead(Timeout: Integer): Boolean;
var
ti, tr: Integer;
n: integer;
begin
if (FHeartbeatRate <> 0) and (Timeout <> -1) then
begin
ti := Timeout div FHeartbeatRate;
tr := Timeout mod FHeartbeatRate;
end
else
begin
ti := 0;
tr := Timeout;
end;
Result := InternalCanRead(tr);
if not Result then
for n := 0 to ti do
begin
DoHeartbeat;
if FStopFlag then
begin
Result := False;
FStopFlag := False;
Break;
end;
Result := InternalCanRead(FHeartbeatRate);
if Result then
break;
end;
ExceptCheck; ExceptCheck;
if Result then if Result then
DoStatus(HR_CanRead, ''); DoStatus(HR_CanRead, '');
@ -2878,6 +2976,19 @@ begin
end; end;
end; end;
procedure TBlockSocket.DoHeartbeat;
begin
if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then
begin
OnHeartbeat(Self);
end;
end;
function TBlockSocket.GetErrorDescEx: string;
begin
Result := GetErrorDesc(FLastError);
end;
class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string;
begin begin
{$IFDEF CIL} {$IFDEF CIL}
@ -3399,7 +3510,7 @@ begin
end end
else else
begin begin
Multicast.imr_multiaddr.S_addr := strtoip(MCastIP); Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
Multicast.imr_interface.S_addr := INADDR_ANY; Multicast.imr_interface.S_addr := INADDR_ANY;
SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP, SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP,
pchar(@Multicast), SizeOf(Multicast))); pchar(@Multicast), SizeOf(Multicast)));
@ -3425,7 +3536,7 @@ begin
end end
else else
begin begin
Multicast.imr_multiaddr.S_addr := strtoip(MCastIP); Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
Multicast.imr_interface.S_addr := INADDR_ANY; Multicast.imr_interface.S_addr := INADDR_ANY;
SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP, SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP,
pchar(@Multicast), SizeOf(Multicast))); pchar(@Multicast), SizeOf(Multicast)));
@ -3503,11 +3614,20 @@ begin
FSSL.Free; FSSL.Free;
end; end;
function TTCPBlockSocket.GetErrorDescEx: string;
begin
Result := inherited GetErrorDescEx;
if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then
begin
Result := self.SSL.LastErrorDesc;
end;
end;
procedure TTCPBlockSocket.CloseSocket; procedure TTCPBlockSocket.CloseSocket;
begin begin
if FSSL.SSLEnabled then if FSSL.SSLEnabled then
FSSL.Shutdown; FSSL.Shutdown;
if FSocket <> INVALID_SOCKET then if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then
begin begin
Synsock.Shutdown(FSocket, 1); Synsock.Shutdown(FSocket, 1);
Purge; Purge;
@ -3515,6 +3635,14 @@ begin
inherited CloseSocket; inherited CloseSocket;
end; end;
procedure TTCPBlockSocket.DoAfterConnect;
begin
if assigned(OnAfterConnect) then
begin
OnAfterConnect(Self);
end;
end;
function TTCPBlockSocket.WaitingData: Integer; function TTCPBlockSocket.WaitingData: Integer;
begin begin
Result := 0; Result := 0;
@ -3587,6 +3715,8 @@ begin
HTTPTunnelDoConnect(IP, Port) HTTPTunnelDoConnect(IP, Port)
else else
inherited Connect(IP, Port); inherited Connect(IP, Port);
if FLasterror = 0 then
DoAfterConnect;
end; end;
procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string); procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string);
@ -3645,7 +3775,7 @@ end;
procedure TTCPBlockSocket.SSLDoConnect; procedure TTCPBlockSocket.SSLDoConnect;
begin begin
FLastError := 0; ResetLastError;
if not FSSL.Connect then if not FSSL.Connect then
FLastError := WSASYSNOTREADY; FLastError := WSASYSNOTREADY;
ExceptCheck; ExceptCheck;
@ -3653,7 +3783,7 @@ end;
procedure TTCPBlockSocket.SSLDoShutdown; procedure TTCPBlockSocket.SSLDoShutdown;
begin begin
FLastError := 0; ResetLastError;
FSSL.BiShutdown; FSSL.BiShutdown;
end; end;
@ -3702,7 +3832,8 @@ begin
Result := 0; Result := 0;
if TestStopFlag then if TestStopFlag then
Exit; Exit;
FLastError := 0; ResetLastError;
LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv);
Result := FSSL.RecvBuffer(Buffer, Len); Result := FSSL.RecvBuffer(Buffer, Len);
if FSSL.LastError <> 0 then if FSSL.LastError <> 0 then
FLastError := WSASYSNOTREADY; FLastError := WSASYSNOTREADY;
@ -3729,7 +3860,7 @@ begin
Result := 0; Result := 0;
if TestStopFlag then if TestStopFlag then
Exit; Exit;
FLastError := 0; ResetLastError;
DoMonitor(True, Buffer, Length); DoMonitor(True, Buffer, Length);
{$IFDEF CIL} {$IFDEF CIL}
Result := FSSL.SendBuffer(Buffer, Length); Result := FSSL.SendBuffer(Buffer, Length);
@ -3771,7 +3902,7 @@ end;
function TTCPBlockSocket.SSLAcceptConnection: Boolean; function TTCPBlockSocket.SSLAcceptConnection: Boolean;
begin begin
FLastError := 0; ResetLastError;
if not FSSL.Accept then if not FSSL.Accept then
FLastError := WSASYSNOTREADY; FLastError := WSASYSNOTREADY;
ExceptCheck; ExceptCheck;
@ -3881,7 +4012,7 @@ end;
procedure TCustomSSL.ReturnError; procedure TCustomSSL.ReturnError;
begin begin
FLastError := -1; FLastError := -1;
FLastErrorDesc := 'SLL is not implemented!'; FLastErrorDesc := 'SSL/TLS support is not compiled!';
end; end;
function TCustomSSL.LibVersion: String; function TCustomSSL.LibVersion: String;

8
dnssend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 002.007.003 | | Project : Ararat Synapse | 002.007.004 |
|==============================================================================| |==============================================================================|
| Content: DNS client | | Content: DNS client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | | Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -63,7 +63,7 @@ uses
blcksock, synautil, synaip, synsock; blcksock, synautil, synaip, synsock;
const const
cDnsProtocol = 'domain'; cDnsProtocol = '53';
QTYPE_A = 1; QTYPE_A = 1;
QTYPE_NS = 2; QTYPE_NS = 2;

22
ftpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 003.004.008 | | Project : Ararat Synapse | 003.005.000 |
|==============================================================================| |==============================================================================|
| Content: FTP client | | Content: FTP client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2005. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -62,8 +62,8 @@ uses
blcksock, synautil, synaip, synsock; blcksock, synautil, synaip, synsock;
const const
cFtpProtocol = 'ftp'; cFtpProtocol = '21';
cFtpDataProtocol = 'ftp-data'; cFtpDataProtocol = '20';
{:Terminating value for TLogonActions} {:Terminating value for TLogonActions}
FTP_OK = 255; FTP_OK = 255;
@ -314,6 +314,9 @@ type
function ChangeWorkingDir(const Directory: string): Boolean; virtual; function ChangeWorkingDir(const Directory: string): Boolean; virtual;
{:walk to upper directory on FTP server.} {:walk to upper directory on FTP server.}
function ChangeToParentDir: Boolean; virtual;
{:walk to root directory on FTP server. (May not work with all servers properly!)}
function ChangeToRootDir: Boolean; virtual; function ChangeToRootDir: Boolean; virtual;
{:Delete Directory on FTP server.} {:Delete Directory on FTP server.}
@ -872,7 +875,7 @@ begin
FDSock.Bind(FSock.GetLocalSinIP, s); FDSock.Bind(FSock.GetLocalSinIP, s);
if FDSock.LastError <> 0 then if FDSock.LastError <> 0 then
Exit; Exit;
FDSock.SetLinger(True, 10); FDSock.SetLinger(True, 10000);
FDSock.Listen; FDSock.Listen;
FDSock.GetSins; FDSock.GetSins;
FDataIP := FDSock.GetLocalSinIP; FDataIP := FDSock.GetLocalSinIP;
@ -1143,11 +1146,16 @@ begin
Result := (FTPCommand('CWD ' + Directory) div 100) = 2; Result := (FTPCommand('CWD ' + Directory) div 100) = 2;
end; end;
function TFTPSend.ChangeToRootDir: Boolean; function TFTPSend.ChangeToParentDir: Boolean;
begin begin
Result := (FTPCommand('CDUP') div 100) = 2; Result := (FTPCommand('CDUP') div 100) = 2;
end; end;
function TFTPSend.ChangeToRootDir: Boolean;
begin
Result := ChangeWorkingDir('/');
end;
function TFTPSend.DeleteDir(const Directory: string): Boolean; function TFTPSend.DeleteDir(const Directory: string): Boolean;
begin begin
Result := (FTPCommand('RMD ' + Directory) div 100) = 2; Result := (FTPCommand('RMD ' + Directory) div 100) = 2;

53
httpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 003.010.005 | | Project : Ararat Synapse | 003.011.003 |
|==============================================================================| |==============================================================================|
| Content: HTTP client | | Content: HTTP client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2006. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -93,6 +93,7 @@ type
FUploadSize: integer; FUploadSize: integer;
FRangeStart: integer; FRangeStart: integer;
FRangeEnd: integer; FRangeEnd: integer;
FAddPortNumberToHost: Boolean;
function ReadUnknown: Boolean; function ReadUnknown: Boolean;
function ReadIdentity(Size: Integer): Boolean; function ReadIdentity(Size: Integer): Boolean;
function ReadChunked: Boolean; function ReadChunked: Boolean;
@ -203,6 +204,10 @@ type
property UploadSize: integer read FUploadSize; property UploadSize: integer read FUploadSize;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock; property Sock: TTCPBlockSocket read FSock;
{:To have possibility to switch off port number in 'Host:' HTTP header, by
default @TRUE. Some buggy servers not like port informations in this header.}
property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost;
end; end;
{:A very usefull function, and example of use can be found in the THTTPSend {:A very usefull function, and example of use can be found in the THTTPSend
@ -272,6 +277,7 @@ begin
FUserAgent := 'Mozilla/4.0 (compatible; Synapse)'; FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
FDownloadSize := 0; FDownloadSize := 0;
FUploadSize := 0; FUploadSize := 0;
FAddPortNumberToHost := true;
Clear; Clear;
end; end;
@ -407,7 +413,7 @@ begin
if FUserAgent <> '' then if FUserAgent <> '' then
FHeaders.Insert(0, 'User-Agent: ' + FUserAgent); FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
{ setting Ranges } { setting Ranges }
if FRangeStart > 0 then if (FRangeStart > 0) or (FRangeEnd > 0) then
begin begin
if FRangeEnd >= FRangeStart then if FRangeEnd >= FRangeStart then
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd)) FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd))
@ -437,7 +443,7 @@ begin
s := '[' + Host + ']' s := '[' + Host + ']'
else else
s := Host; s := Host;
if Port<>'80' then if FAddPortNumberToHost and (Port <> '80') then
FHeaders.Insert(0, 'Host: ' + s + ':' + Port) FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
else else
FHeaders.Insert(0, 'Host: ' + s); FHeaders.Insert(0, 'Host: ' + s);
@ -465,7 +471,6 @@ begin
{ connect } { connect }
if not InternalConnect(UpperCase(Prot) = 'HTTPS') then if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
begin begin
FSock.CloseSocket;
FAliveHost := ''; FAliveHost := '';
FAlivePort := ''; FAlivePort := '';
Exit; Exit;
@ -538,18 +543,20 @@ begin
if s <> '' then if s <> '' then
Break; Break;
until FSock.LastError <> 0; until FSock.LastError <> 0;
if Pos('HTTP/', UpperCase(s)) = 1 then repeat
begin if Pos('HTTP/', UpperCase(s)) = 1 then
FHeaders.Add(s); begin
DecodeStatus(s); FHeaders.Add(s);
end DecodeStatus(s);
else end
begin else
{ old HTTP 0.9 and some buggy servers not send result } begin
s := s + CRLF; { old HTTP 0.9 and some buggy servers not send result }
WriteStrToStream(FDocument, s); s := s + CRLF;
FResultCode := 0; WriteStrToStream(FDocument, s);
end; FResultCode := 0;
end;
until (FSock.LastError <> 0) or (FResultCode <> 100);
end end
else else
FHeaders.Add(Status100Error); FHeaders.Add(Status100Error);
@ -566,7 +573,7 @@ begin
if Pos('CONTENT-LENGTH:', su) = 1 then if Pos('CONTENT-LENGTH:', su) = 1 then
begin begin
Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1); Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
if Size <> -1 then if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
FTransferEncoding := TE_IDENTITY; FTransferEncoding := TE_IDENTITY;
end; end;
if Pos('CONTENT-TYPE:', su) = 1 then if Pos('CONTENT-TYPE:', su) = 1 then
@ -612,12 +619,17 @@ function THTTPSend.ReadUnknown: Boolean;
var var
s: string; s: string;
begin begin
Result := false;
repeat repeat
s := FSock.RecvPacket(FTimeout); s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
WriteStrToStream(FDocument, s); WriteStrToStream(FDocument, s);
until FSock.LastError <> 0; until FSock.LastError <> 0;
Result := FSock.LastError = WSAECONNRESET; if FSock.LastError = WSAECONNRESET then
begin
Result := true;
FSock.ResetLastError;
end;
end; end;
function THTTPSend.ReadIdentity(Size: Integer): Boolean; function THTTPSend.ReadIdentity(Size: Integer): Boolean;
@ -719,6 +731,7 @@ begin
HTTP.Document.CopyFrom(Data, 0); HTTP.Document.CopyFrom(Data, 0);
HTTP.MimeType := 'Application/octet-stream'; HTTP.MimeType := 'Application/octet-stream';
Result := HTTP.HTTPMethod('POST', URL); Result := HTTP.HTTPMethod('POST', URL);
Data.Size := 0;
if Result then if Result then
begin begin
Data.Seek(0, soFromBeginning); Data.Seek(0, soFromBeginning);

4
imapsend.pas
View File

@ -177,8 +177,8 @@ type
{:Append given message to specified folder.} {:Append given message to specified folder.}
function AppendMess(ToFolder: string; const Mess: TStrings): Boolean; function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
{:'Delete' message from currect selected folder. It mark message as Deleted. {:'Delete' message from current selected folder. It mark message as Deleted.
Real deleting waill be done after sucessfull @link(CloseFolder) or Real deleting will be done after sucessfull @link(CloseFolder) or
@link(ExpungeFolder)} @link(ExpungeFolder)}
function DeleteMess(MessID: integer): boolean; function DeleteMess(MessID: integer): boolean;

17
mimeinln.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.001.009 | | Project : Ararat Synapse | 001.001.011 |
|==============================================================================| |==============================================================================|
| Content: Inline MIME support procedures and functions | | Content: Inline MIME support procedures and functions |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer | | Copyright (c)1999-2006, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -220,14 +220,7 @@ var
begin begin
if NeedInline(Value) then if NeedInline(Value) then
begin begin
c := IdealCharsetCoding(Value, FromCP, c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10,
KOI8_R, KOI8_U
{$IFNDEF CIL} //error URW778 ??? :-O
, GB2312, EUC_KR, ISO_2022_JP, EUC_TW
{$ENDIF}
]);
Result := InlineEncode(Value, FromCP, c); Result := InlineEncode(Value, FromCP, c);
end end
else else
@ -252,7 +245,7 @@ begin
if sd = '' then if sd = '' then
Result := se Result := se
else else
Result := '"' + InlineCodeEx(sd, FromCP) + '"<' + se + '>'; Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
end; end;
{==============================================================================} {==============================================================================}

23
mimemess.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 002.005.000 | | Project : Ararat Synapse | 002.005.002 |
|==============================================================================| |==============================================================================|
| Content: MIME message object | | Content: MIME message object |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer | | Copyright (c)1999-2006, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2005. | | Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -90,7 +90,7 @@ type
destructor Destroy; override; destructor Destroy; override;
{:Clears all data fields.} {:Clears all data fields.}
procedure Clear; procedure Clear; virtual;
{Add headers from from this object to Value.} {Add headers from from this object to Value.}
procedure EncodeHeaders(const Value: TStrings); virtual; procedure EncodeHeaders(const Value: TStrings); virtual;
@ -171,7 +171,7 @@ type
destructor Destroy; override; destructor Destroy; override;
{:Reset component to default state.} {:Reset component to default state.}
procedure Clear; procedure Clear; virtual;
{:Add MIME part as subpart of PartParent. If you need set root MIME part, {:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then one subpart, then set as PartParent @NIL value. If you need set more then one subpart,
@ -362,7 +362,7 @@ begin
if s = '' then if s = '' then
s := InlineEmailEx(FCCList[n], FCharsetCode) s := InlineEmailEx(FCCList[n], FCharsetCode)
else else
s := s + ' , ' + InlineEmailEx(FCCList[n], FCharsetCode); s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode);
if s <> '' then if s <> '' then
Value.Insert(0, 'CC: ' + s); Value.Insert(0, 'CC: ' + s);
Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate)); Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
@ -373,7 +373,7 @@ begin
if s = '' then if s = '' then
s := InlineEmailEx(FToList[n], FCharsetCode) s := InlineEmailEx(FToList[n], FCharsetCode)
else else
s := s + ' , ' + InlineEmailEx(FToList[n], FCharsetCode); s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode);
if s <> '' then if s <> '' then
Value.Insert(0, 'To: ' + s); Value.Insert(0, 'To: ' + s);
Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode)); Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
@ -624,14 +624,7 @@ begin
Secondary := 'plain'; Secondary := 'plain';
Description := 'Message text'; Description := 'Message text';
Disposition := 'inline'; Disposition := 'inline';
CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets);
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10,
KOI8_R, KOI8_U
{$IFNDEF CIL} //error URW778 ??? :-O
, GB2312, EUC_KR, ISO_2022_JP, EUC_TW
{$ENDIF}
]);
EncodingCode := ME_QUOTED_PRINTABLE; EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart; EncodePart;
EncodePartHeader; EncodePartHeader;

28
mimepart.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 002.007.005 | | Project : Ararat Synapse | 002.007.007 |
|==============================================================================| |==============================================================================|
| Content: MIME support procedures and functions | | Content: MIME support procedures and functions |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2005. | | Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -733,7 +733,7 @@ end;
procedure TMIMEPart.DecodePart; procedure TMIMEPart.DecodePart;
var var
n: Integer; n: Integer;
s, t: string; s, t, t2: string;
b: Boolean; b: Boolean;
begin begin
FDecodedLines.Clear; FDecodedLines.Clear;
@ -758,8 +758,8 @@ begin
if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then
begin begin
b := false; b := false;
t := uppercase(s); t2 := uppercase(s);
t := SeparateLeft(t, '</HEAD>'); t := SeparateLeft(t2, '</HEAD>');
if length(t) <> length(s) then if length(t) <> length(s) then
begin begin
t := SeparateRight(t, '<HEAD>'); t := SeparateRight(t, '<HEAD>');
@ -767,6 +767,15 @@ begin
t := ReplaceString(t, ' ', ''); t := ReplaceString(t, ' ', '');
b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
end; end;
//workaround for shitty M$ Outlook 11 which is placing this information
//outside <head> section
if not b then
begin
t := Copy(t2, 1, 2048);
t := ReplaceString(t, '"', '');
t := ReplaceString(t, ' ', '');
b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
end;
if not b then if not b then
s := CharsetConversion(s, FCharsetCode, FTargetCharset); s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end end
@ -1067,8 +1076,11 @@ end;
procedure TMIMEPart.SetCharset(Value: string); procedure TMIMEPart.SetCharset(Value: string);
begin begin
FCharset := Value; if value <> '' then
FCharsetCode := GetCPFromID(Value); begin
FCharset := Value;
FCharsetCode := GetCPFromID(Value);
end;
end; end;
function TMIMEPart.CanSubPart: boolean; function TMIMEPart.CanSubPart: boolean;

8
nntpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.005.000 | | Project : Ararat Synapse | 001.005.001 |
|==============================================================================| |==============================================================================|
| Content: NNTP client | | Content: NNTP client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2005. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -62,7 +62,7 @@ uses
blcksock, synautil; blcksock, synautil;
const const
cNNTPProtocol = 'nntp'; cNNTPProtocol = '119';
type type

342
pingsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 003.001.008 | | Project : Ararat Synapse | 004.000.000 |
|==============================================================================| |==============================================================================|
| Content: PING sender | | Content: PING sender |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -45,11 +45,15 @@
{:@abstract(ICMP PING implementation.) {:@abstract(ICMP PING implementation.)
Allows create PING and TRACEROUTE. Or you can diagnose your network. Allows create PING and TRACEROUTE. Or you can diagnose your network.
Warning: this unit using RAW sockets. On some systems you must have special This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying
rights for using this sort of sockets. So, it working allways when you have to use RAW sockets.
administator/root rights. Otherwise you can have problems!
Note: IPv6 not working under .NET. It is lack of Microsoft's .NET framework. Warning: For use of RAW sockets you must have some special rights on some
systems. So, it working allways when you have administator/root rights.
Otherwise you can have problems!
Note: This unit is NOT portable to .NET!
Use native .NET classes for Ping instead.
} }
{$IFDEF FPC} {$IFDEF FPC}
@ -69,7 +73,11 @@ interface
uses uses
SysUtils, SysUtils,
synsock, blcksock, synautil; synsock, blcksock, synautil, synafpc, synaip
{$IFDEF WIN32}
, windows
{$ENDIF}
;
const const
ICMP_ECHO = 8; ICMP_ECHO = 8;
@ -83,28 +91,6 @@ const
ICMP6_TIME_EXCEEDED = 3; ICMP6_TIME_EXCEEDED = 3;
type type
{:Record for ICMP ECHO packet header.}
TIcmpEchoHeader = record
i_type: Byte;
i_code: Byte;
i_checkSum: Word;
i_Id: Word;
i_seq: Word;
TimeStamp: integer;
end;
{:record used internally by TPingSend for compute checksum of ICMPv6 packet
pseudoheader.}
TICMP6Packet = record
in_source: TInAddr6;
in_dest: TInAddr6;
Length: integer;
free0: Byte;
free1: Byte;
free2: Byte;
proto: Byte;
end;
{:List of possible ICMP reply packet types.} {:List of possible ICMP reply packet types.}
TICMPError = ( TICMPError = (
IE_NoError, IE_NoError,
@ -117,10 +103,7 @@ type
IE_UnreachPort IE_UnreachPort
); );
{:@abstract(Implementation of ICMP PING and ICMPv6 PING.) {:@abstract(Implementation of ICMP PING and ICMPv6 PING.)}
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TPINGSend = class(TSynaClient) TPINGSend = class(TSynaClient)
private private
FSock: TICMPBlockSocket; FSock: TICMPBlockSocket;
@ -137,10 +120,17 @@ type
FReplyCode: byte; FReplyCode: byte;
FReplyError: TICMPError; FReplyError: TICMPError;
FReplyErrorDesc: string; FReplyErrorDesc: string;
FTTL: Byte;
Fsin: TVarSin;
function Checksum(Value: string): Word; function Checksum(Value: string): Word;
function Checksum6(Value: string): Word; function Checksum6(Value: string): Word;
function ReadPacket: Boolean; function ReadPacket: Boolean;
procedure TranslateError; procedure TranslateError;
procedure TranslateErrorIpHlp(value: integer);
function InternalPing(const Host: string): Boolean;
function InternalPingIpHlp(const Host: string): Boolean;
function IsHostIP6(const Host: string): Boolean;
procedure GenErrorDesc;
public public
{:Send ICMP ping to host and count @link(pingtime). If ping OK, result is {:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
@true.} @true.}
@ -176,6 +166,9 @@ type
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TICMPBlockSocket read FSock; property Sock: TICMPBlockSocket read FSock;
{:TTL value for ICMP query}
property TTL: byte read FTTL write FTTL;
end; end;
{:A very useful function and example of its use would be found in the TPINGSend {:A very useful function and example of its use would be found in the TPINGSend
@ -189,6 +182,82 @@ function TraceRouteHost(const Host: string): string;
implementation implementation
type
{:Record for ICMP ECHO packet header.}
TIcmpEchoHeader = record
i_type: Byte;
i_code: Byte;
i_checkSum: Word;
i_Id: Word;
i_seq: Word;
TimeStamp: integer;
end;
{:record used internally by TPingSend for compute checksum of ICMPv6 packet
pseudoheader.}
TICMP6Packet = record
in_source: TInAddr6;
in_dest: TInAddr6;
Length: integer;
free0: Byte;
free1: Byte;
free2: Byte;
proto: Byte;
end;
{$IFDEF WIN32}
const
DLLIcmpName = 'iphlpapi.dll';
type
TIP_OPTION_INFORMATION = packed record
TTL: Byte;
TOS: Byte;
Flags: Byte;
OptionsSize: Byte;
OptionsData: PChar;
end;
PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;
TICMP_ECHO_REPLY = packed record
Address: TInAddr;
Status: integer;
RoundTripTime: integer;
DataSize: Word;
Reserved: Word;
Data: pointer;
Options: TIP_OPTION_INFORMATION;
end;
PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY;
TICMPV6_ECHO_REPLY = packed record
Address: TSockAddrIn6;
Status: integer;
RoundTripTime: integer;
end;
PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;
TIcmpCreateFile = function: integer; stdcall;
TIcmpCloseHandle = function(handle: integer): boolean; stdcall;
TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
TIcmp6CreateFile = function: integer; stdcall;
TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
var
IcmpDllHandle: TLibHandle = 0;
IcmpHelper4: boolean = false;
IcmpHelper6: boolean = false;
IcmpCreateFile: TIcmpCreateFile = nil;
IcmpCloseHandle: TIcmpCloseHandle = nil;
IcmpSendEcho2: TIcmpSendEcho2 = nil;
Icmp6CreateFile: TIcmp6CreateFile = nil;
Icmp6SendEcho2: TIcmp6SendEcho2 = nil;
{$ENDIF}
{==============================================================================} {==============================================================================}
constructor TPINGSend.Create; constructor TPINGSend.Create;
@ -199,6 +268,7 @@ begin
FPacketSize := 32; FPacketSize := 32;
FSeq := 0; FSeq := 0;
Randomize; Randomize;
FTTL := 128;
end; end;
destructor TPINGSend.Destroy; destructor TPINGSend.Destroy;
@ -213,7 +283,69 @@ begin
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
procedure TPINGSend.GenErrorDesc;
begin
case FReplyError of
IE_NoError:
FReplyErrorDesc := '';
IE_Other:
FReplyErrorDesc := 'Unknown error';
IE_TTLExceed:
FReplyErrorDesc := 'TTL Exceeded';
IE_UnreachOther:
FReplyErrorDesc := 'Unknown unreachable';
IE_UnreachRoute:
FReplyErrorDesc := 'No route to destination';
IE_UnreachAdmin:
FReplyErrorDesc := 'Administratively prohibited';
IE_UnreachAddr:
FReplyErrorDesc := 'Address unreachable';
IE_UnreachPort:
FReplyErrorDesc := 'Port unreachable';
end;
end;
function TPINGSend.IsHostIP6(const Host: string): Boolean;
var
f: integer;
begin
f := AF_UNSPEC;
if IsIp(Host) then
f := AF_INET
else
if IsIp6(Host) then
f := AF_INET6;
synsock.SetVarSin(Fsin, host, '0', f,
IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4);
result := Fsin.sin_family = AF_INET6;
end;
function TPINGSend.Ping(const Host: string): Boolean; function TPINGSend.Ping(const Host: string): Boolean;
var
b: boolean;
begin
FPingTime := -1;
FReplyFrom := '';
FReplyType := 0;
FReplyCode := 0;
FReplyError := IE_Other;
GenErrorDesc;
FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
{$IFDEF WIN32}
b := IsHostIP6(host);
if not(b) and IcmpHelper4 then
result := InternalPingIpHlp(host)
else
if b and IcmpHelper6 then
result := InternalPingIpHlp(host)
else
result := InternalPing(host);
{$ELSE}
result := InternalPing(host);
{$ENDIF}
end;
function TPINGSend.InternalPing(const Host: string): Boolean;
var var
IPHeadPtr: ^TIPHeader; IPHeadPtr: ^TIPHeader;
IpHdrLen: Integer; IpHdrLen: Integer;
@ -223,12 +355,7 @@ var
IcmpReqHead: string; IcmpReqHead: string;
begin begin
Result := False; Result := False;
FPingTime := -1; FSock.TTL := FTTL;
FReplyFrom := '';
FReplyType := 0;
FReplyCode := 0;
FReplyError := IE_NoError;
FReplyErrorDesc := '';
FSock.Bind(FIPInterface, cAnyPort); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(Host, '0'); FSock.Connect(Host, '0');
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
@ -246,7 +373,6 @@ begin
FIcmpEchoReply := ICMP_ECHOREPLY; FIcmpEchoReply := ICMP_ECHOREPLY;
FIcmpUnreach := ICMP_UNREACH; FIcmpUnreach := ICMP_UNREACH;
end; end;
FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
IcmpEchoHeaderPtr := Pointer(FBuffer); IcmpEchoHeaderPtr := Pointer(FBuffer);
with IcmpEchoHeaderPtr^ do with IcmpEchoHeaderPtr^ do
begin begin
@ -414,25 +540,96 @@ begin
FReplyError := IE_Other; FReplyError := IE_Other;
end; end;
end; end;
case FReplyError of GenErrorDesc;
IE_NoError: end;
FReplyErrorDesc := '';
IE_Other: procedure TPINGSend.TranslateErrorIpHlp(value: integer);
FReplyErrorDesc := 'Unknown error'; begin
IE_TTLExceed: case value of
FReplyErrorDesc := 'TTL Exceeded'; 11000, 0:
IE_UnreachOther: FReplyError := IE_NoError;
FReplyErrorDesc := 'Unknown unreachable'; 11013:
IE_UnreachRoute: FReplyError := IE_TTLExceed;
FReplyErrorDesc := 'No route to destination'; 11002:
IE_UnreachAdmin: FReplyError := IE_UnreachRoute;
FReplyErrorDesc := 'Administratively prohibited'; 11003:
IE_UnreachAddr: FReplyError := IE_UnreachAddr;
FReplyErrorDesc := 'Address unreachable'; 11005:
IE_UnreachPort: FReplyError := IE_UnreachPort;
FReplyErrorDesc := 'Port unreachable'; 11004:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_Other;
end;
GenErrorDesc;
end;
function TPINGSend.InternalPingIpHlp(const Host: string): Boolean;
{$IFDEF WIN32}
var
PingIp6: boolean;
PingHandle: integer;
r: integer;
ipo: TIP_OPTION_INFORMATION;
RBuff: string;
ip4reply: PICMP_ECHO_REPLY;
ip6reply: PICMPV6_ECHO_REPLY;
ip6: TSockAddrIn6;
begin
Result := False;
PingIp6 := Fsin.sin_family = AF_INET6;
if pingIp6 then
PingHandle := Icmp6CreateFile
else
PingHandle := IcmpCreateFile;
if PingHandle <> -1 then
begin
try
ipo.TTL := FTTL;
ipo.TOS := 0;
ipo.Flags := 0;
ipo.OptionsSize := 0;
ipo.OptionsData := nil;
setlength(RBuff, 4096);
if pingIp6 then
begin
FillChar(ip6, sizeof(ip6), 0);
r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin,
Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout);
if r > 0 then
begin
RBuff := #0 + #0 + RBuff;
ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff));
FPingTime := ip6reply^.RoundTripTime;
ip6reply^.Address.sin6_family := AF_INET6;
FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address));
TranslateErrorIpHlp(ip6reply^.Status);
Result := True;
end;
end
else
begin
r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr,
Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout);
if r > 0 then
begin
ip4reply := PICMP_ECHO_REPLY(pointer(RBuff));
FPingTime := ip4reply^.RoundTripTime;
FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr));
TranslateErrorIpHlp(ip4reply^.Status);
Result := True;
end;
end
finally
IcmpCloseHandle(PingHandle);
end;
end; end;
end; end;
{$ELSE}
begin
result := false;
end;
{$ENDIF}
{==============================================================================} {==============================================================================}
@ -459,7 +656,7 @@ begin
try try
ttl := 1; ttl := 1;
repeat repeat
ping.Sock.TTL := ttl; ping.TTL := ttl;
inc(ttl); inc(ttl);
if ttl > 30 then if ttl > 30 then
Break; Break;
@ -481,4 +678,31 @@ begin
end; end;
end; end;
{$IFDEF WIN32}
initialization
begin
IcmpHelper4 := false;
IcmpHelper6 := false;
IcmpDllHandle := LoadLibrary(DLLIcmpName);
if IcmpDllHandle <> 0 then
begin
IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile');
IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle');
IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2');
Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile');
Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2');
IcmpHelper4 := assigned(IcmpCreateFile)
and assigned(IcmpCloseHandle)
and assigned(IcmpSendEcho2);
IcmpHelper6 := assigned(Icmp6CreateFile)
and assigned(Icmp6SendEcho2);
end;
end;
finalization
begin
FreeLibrary(IcmpDllHandle);
end;
{$ENDIF}
end. end.

87
pop3send.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 002.005.000 | | Project : Ararat Synapse | 002.006.000 |
|==============================================================================| |==============================================================================|
| Content: POP3 client | | Content: POP3 client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2005. | | Portions created by Lukas Gebauer are Copyright (c)2001-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -61,7 +61,7 @@ uses
blcksock, synautil, synacode; blcksock, synautil, synacode;
const const
cPop3Protocol = 'pop3'; cPop3Protocol = '110';
type type
@ -98,6 +98,11 @@ type
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
{:You can call any custom by this method. Call Command without trailing CRLF.
If MultiLine parameter is @true, multilined response are expected.
Result is @true on sucess.}
function CustomCommand(const Command: string; MultiLine: Boolean): boolean;
{:Call CAPA command for get POP3 server capabilites. {:Call CAPA command for get POP3 server capabilites.
note: not all servers support this command!} note: not all servers support this command!}
function Capability: Boolean; function Capability: Boolean;
@ -237,17 +242,25 @@ begin
Delete(s, 1, 1); Delete(s, 1, 1);
FFullResult.Add(s); FFullResult.Add(s);
until FSock.LastError <> 0; until FSock.LastError <> 0;
if not Full and (Result = 1) then
FFullResult.Add(SeparateRight(FResultString, ' '));
if FSock.LastError <> 0 then
Result := 0;
FResultCode := Result; FResultCode := Result;
end; end;
function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
begin
FSock.SendString(Command + CRLF);
Result := ReadResult(MultiLine) <> 0;
end;
function TPOP3Send.AuthLogin: Boolean; function TPOP3Send.AuthLogin: Boolean;
begin begin
Result := False; Result := False;
FSock.SendString('USER ' + FUserName + CRLF); if not CustomCommand('USER ' + FUserName, False) then
if ReadResult(False) <> 1 then exit;
Exit; Result := CustomCommand('PASS ' + FPassword, False)
FSock.SendString('PASS ' + FPassword + CRLF);
Result := ReadResult(False) = 1;
end; end;
function TPOP3Send.AuthAPOP: Boolean; function TPOP3Send.AuthAPOP: Boolean;
@ -255,8 +268,7 @@ var
s: string; s: string;
begin begin
s := StrToHex(MD5(FTimeStamp + FPassWord)); s := StrToHex(MD5(FTimeStamp + FPassWord));
FSock.SendString('APOP ' + FUserName + ' ' + s + CRLF); Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
Result := ReadResult(False) = 1;
end; end;
function TPOP3Send.Connect: Boolean; function TPOP3Send.Connect: Boolean;
@ -278,8 +290,7 @@ end;
function TPOP3Send.Capability: Boolean; function TPOP3Send.Capability: Boolean;
begin begin
FPOP3cap.Clear; FPOP3cap.Clear;
FSock.SendString('CAPA' + CRLF); Result := CustomCommand('CAPA', True);
Result := ReadResult(True) = 1;
if Result then if Result then
FPOP3cap.AddStrings(FFullResult); FPOP3cap.AddStrings(FFullResult);
end; end;
@ -328,35 +339,31 @@ end;
function TPOP3Send.Logout: Boolean; function TPOP3Send.Logout: Boolean;
begin begin
FSock.SendString('QUIT' + CRLF); Result := CustomCommand('QUIT', False);
Result := ReadResult(False) = 1;
FSock.CloseSocket; FSock.CloseSocket;
end; end;
function TPOP3Send.Reset: Boolean; function TPOP3Send.Reset: Boolean;
begin begin
FSock.SendString('RSET' + CRLF); Result := CustomCommand('RSET', False);
Result := ReadResult(False) = 1;
end; end;
function TPOP3Send.NoOp: Boolean; function TPOP3Send.NoOp: Boolean;
begin begin
FSock.SendString('NOOP' + CRLF); Result := CustomCommand('NOOP', False);
Result := ReadResult(False) = 1;
end; end;
function TPOP3Send.Stat: Boolean; function TPOP3Send.Stat: Boolean;
var var
s: string; s: string;
begin begin
Result := False; Result := CustomCommand('STAT', False);
FSock.SendString('STAT' + CRLF); if Result then
if ReadResult(False) <> 1 then begin
Exit; s := SeparateRight(ResultString, '+OK ');
s := SeparateRight(ResultString, '+OK '); FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); end;
Result := True;
end; end;
function TPOP3Send.List(Value: Integer): Boolean; function TPOP3Send.List(Value: Integer): Boolean;
@ -365,10 +372,10 @@ var
n: integer; n: integer;
begin begin
if Value = 0 then if Value = 0 then
FSock.SendString('LIST' + CRLF) s := 'LIST'
else else
FSock.SendString('LIST ' + IntToStr(Value) + CRLF); s := 'LIST ' + IntToStr(Value);
Result := ReadResult(Value = 0) = 1; Result := CustomCommand(s, Value = 0);
FListSize := 0; FListSize := 0;
if Result then if Result then
if Value <> 0 then if Value <> 0 then
@ -383,8 +390,7 @@ end;
function TPOP3Send.Retr(Value: Integer): Boolean; function TPOP3Send.Retr(Value: Integer): Boolean;
begin begin
FSock.SendString('RETR ' + IntToStr(Value) + CRLF); Result := CustomCommand('RETR ' + IntToStr(Value), True);
Result := ReadResult(True) = 1;
end; end;
//based on code by Miha Vrhovnik //based on code by Miha Vrhovnik
@ -423,30 +429,29 @@ end;
function TPOP3Send.Dele(Value: Integer): Boolean; function TPOP3Send.Dele(Value: Integer): Boolean;
begin begin
FSock.SendString('DELE ' + IntToStr(Value) + CRLF); Result := CustomCommand('DELE ' + IntToStr(Value), False);
Result := ReadResult(False) = 1;
end; end;
function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
begin begin
FSock.SendString('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines) + CRLF); Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
Result := ReadResult(True) = 1;
end; end;
function TPOP3Send.Uidl(Value: Integer): Boolean; function TPOP3Send.Uidl(Value: Integer): Boolean;
var
s: string;
begin begin
if Value = 0 then if Value = 0 then
FSock.SendString('UIDL' + CRLF) s := 'UIDL'
else else
FSock.SendString('UIDL ' + IntToStr(Value) + CRLF); s := 'UIDL ' + IntToStr(Value);
Result := ReadResult(Value = 0) = 1; Result := CustomCommand(s, Value = 0);
end; end;
function TPOP3Send.StartTLS: Boolean; function TPOP3Send.StartTLS: Boolean;
begin begin
Result := False; Result := False;
FSock.SendString('STLS' + CRLF); if CustomCommand('STLS', False) then
if ReadResult(False) = 1 then
begin begin
Fsock.SSLDoConnect; Fsock.SSLDoConnect;
Result := FSock.LastError = 0; Result := FSock.LastError = 0;

8
smtpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 003.004.002 | | Project : Ararat Synapse | 003.004.003 |
|==============================================================================| |==============================================================================|
| Content: SMTP client | | Content: SMTP client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2005. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -62,7 +62,7 @@ uses
blcksock, synautil, synacode; blcksock, synautil, synacode;
const const
cSmtpProtocol = 'smtp'; cSmtpProtocol = '25';
type type
{:@abstract(Implementation of SMTP and ESMTP procotol), {:@abstract(Implementation of SMTP and ESMTP procotol),

7
snmpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 003.000.008 | | Project : Ararat Synapse | 003.000.009 |
|==============================================================================| |==============================================================================|
| Content: SNMP client | | Content: SNMP client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | | Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -679,6 +679,7 @@ begin
ASNObject(Self.FCommunity, ASN1_OCTSTR); ASNObject(Self.FCommunity, ASN1_OCTSTR);
Result := ASNObject(head + pdu, ASN1_SEQ); Result := ASNObject(head + pdu, ASN1_SEQ);
end; end;
inc(self.FID);
end; end;
procedure TSNMPRec.Clear; procedure TSNMPRec.Clear;

8
sntpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 003.000.001| | Project : Ararat Synapse | 003.000.002 |
|==============================================================================| |==============================================================================|
| Content: SNTP client | | Content: SNTP client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -63,7 +63,7 @@ uses
synsock, blcksock, synautil; synsock, blcksock, synautil;
const const
cNtpProtocol = 'ntp'; cNtpProtocol = '123';
type type

70
ssfpc.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.000.003 | | Project : Ararat Synapse | 001.000.005 |
|==============================================================================| |==============================================================================|
| Content: Socket Independent Platform Layer - FreePascal definition include | | Content: Socket Independent Platform Layer - FreePascal definition include |
|==============================================================================| |==============================================================================|
@ -83,6 +83,8 @@ const
cLocalHost = '127.0.0.1'; cLocalHost = '127.0.0.1';
cAnyHost = '0.0.0.0'; cAnyHost = '0.0.0.0';
c6AnyHost = '::0'; c6AnyHost = '::0';
c6Localhost = '::1';
cLocalHostStr = 'localhost';
type type
TSocket = longint; TSocket = longint;
@ -675,11 +677,16 @@ var
end end
else else
begin begin
a4[1].s_addr := 0; if lowercase(IP) = cLocalHostStr then
Result := WSAHOST_NOT_FOUND; a4[1].s_addr := htonl(INADDR_LOOPBACK)
a4[1] := StrTonetAddr(IP); else
if a4[1].s_addr = INADDR_ANY then begin
Resolvename(ip, a4); a4[1].s_addr := 0;
Result := WSAHOST_NOT_FOUND;
a4[1] := StrTonetAddr(IP);
if a4[1].s_addr = INADDR_ANY then
Resolvename(ip, a4);
end;
if a4[1].s_addr <> INADDR_ANY then if a4[1].s_addr <> INADDR_ANY then
begin begin
Sin.sin_family := AF_INET; Sin.sin_family := AF_INET;
@ -697,11 +704,16 @@ var
end end
else else
begin begin
Result := WSAHOST_NOT_FOUND; if lowercase(IP) = cLocalHostStr then
SET_IN6_IF_ADDR_ANY(@a6[1]); SET_LOOPBACK_ADDR6(@a6[1])
a6[1] := StrTonetAddr6(IP); else
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then begin
Resolvename6(ip, a6); Result := WSAHOST_NOT_FOUND;
SET_IN6_IF_ADDR_ANY(@a6[1]);
a6[1] := StrTonetAddr6(IP);
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
Resolvename6(ip, a6);
end;
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
begin begin
Sin.sin_family := AF_INET6; Sin.sin_family := AF_INET6;
@ -772,26 +784,36 @@ begin
IPList.Clear; IPList.Clear;
if (family = AF_INET) or (family = AF_UNSPEC) then if (family = AF_INET) or (family = AF_UNSPEC) then
begin begin
a4[1] := StrTonetAddr(name); if lowercase(name) = cLocalHostStr then
if a4[1].s_addr = INADDR_ANY then IpList.Add(cLocalHost)
x := Resolvename(name, a4)
else else
x := 1; begin
for n := 1 to x do a4[1] := StrTonetAddr(name);
IpList.Add(netaddrToStr(a4[n])); if a4[1].s_addr = INADDR_ANY then
x := Resolvename(name, a4)
else
x := 1;
for n := 1 to x do
IpList.Add(netaddrToStr(a4[n]));
end;
end; end;
if (family = AF_INET6) or (family = AF_UNSPEC) then if (family = AF_INET6) or (family = AF_UNSPEC) then
begin begin
a6[1] := StrTonetAddr6(name); if lowercase(name) = cLocalHostStr then
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then IpList.Add(c6LocalHost)
x := Resolvename6(name, a6)
else else
x := 1; begin
for n := 1 to x do a6[1] := StrTonetAddr6(name);
IpList.Add(netaddrToStr6(a6[n])); if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
x := Resolvename6(name, a6)
else
x := 1;
for n := 1 to x do
IpList.Add(netaddrToStr6(a6[n]));
end;
end; end;
if IPList.Count = 0 then if IPList.Count = 0 then
IPList.Add(cLocalHost); IPList.Add(cLocalHost);
end; end;

1291
ssl_sbb.pas
View File

File diff suppressed because it is too large Load Diff

23
ssl_streamsec.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.000.005 | | Project : Ararat Synapse | 001.000.006 |
|==============================================================================| |==============================================================================|
| Content: SSL support by StreamSecII | | Content: SSL support by StreamSecII |
|==============================================================================| |==============================================================================|
@ -98,6 +98,7 @@ type
FSlave: TMyTLSSynSockSlave; FSlave: TMyTLSSynSockSlave;
FIsServer: Boolean; FIsServer: Boolean;
FTLSServer: TCustomTLSInternalServer; FTLSServer: TCustomTLSInternalServer;
FServerCreated: Boolean;
function SSLCheck: Boolean; function SSLCheck: Boolean;
function Init(server:Boolean): Boolean; function Init(server:Boolean): Boolean;
function DeInit: Boolean; function DeInit: Boolean;
@ -204,7 +205,7 @@ end;
function TSSLStreamSec.Init(server:Boolean): Boolean; function TSSLStreamSec.Init(server:Boolean): Boolean;
var var
st: TMemoryStream; st: TMemoryStream;
pass: TSecretKey; pass: ISecretKey;
ws: WideString; ws: WideString;
begin begin
Result := False; Result := False;
@ -218,8 +219,10 @@ begin
else else
if Assigned(TLSInternalServer.GlobalServer) then if Assigned(TLSInternalServer.GlobalServer) then
FSlave.MyTLSServer := TLSInternalServer.GlobalServer FSlave.MyTLSServer := TLSInternalServer.GlobalServer
else else begin
FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil); FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
FServerCreated := True;
end;
if server then if server then
FSlave.MyTLSServer.ClientOrServer := cosServerSide FSlave.MyTLSServer.ClientOrServer := cosServerSide
else else
@ -293,7 +296,7 @@ begin
end; end;
if FPFXfile <> '' then if FPFXfile <> '' then
FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass); FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
if server then if server and FServerCreated then
begin begin
FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer; FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed; FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
@ -306,17 +309,24 @@ begin
end; end;
Result := true; Result := true;
finally finally
pass.Free; pass := nil;
end; end;
end; end;
function TSSLStreamSec.DeInit: Boolean; function TSSLStreamSec.DeInit: Boolean;
var
obj: TObject;
begin begin
Result := True; Result := True;
if assigned(FSlave) then if assigned(FSlave) then
begin begin
FSlave.Close; FSlave.Close;
if FServerCreated then
obj := FSlave.TLSServer
else
obj := nil;
FSlave.Free; FSlave.Free;
obj.Free;
FSlave := nil; FSlave := nil;
end; end;
FSSLEnabled := false; FSSLEnabled := false;
@ -355,7 +365,7 @@ begin
Exit; Exit;
if Prepare(true) then if Prepare(true) then
begin begin
FSlave.Open; FSlave.DoConnect;
SSLCheck; SSLCheck;
if FLastError <> 0 then if FLastError <> 0 then
Exit; Exit;
@ -526,3 +536,4 @@ finalization
end. end.

4
sslinux.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 002.000.007 | | Project : Ararat Synapse | 002.000.008 |
|==============================================================================| |==============================================================================|
| Content: Socket Independent Platform Layer - Linux definition include | | Content: Socket Independent Platform Layer - Linux definition include |
|==============================================================================| |==============================================================================|
@ -163,7 +163,7 @@ type
0: (S6_addr: packed array [0..15] of byte); 0: (S6_addr: packed array [0..15] of byte);
1: (u6_addr8: packed array [0..15] of byte); 1: (u6_addr8: packed array [0..15] of byte);
2: (u6_addr16: packed array [0..7] of word); 2: (u6_addr16: packed array [0..7] of word);
3: (u6_addr32: packed array [0..7] of integer); 3: (u6_addr32: packed array [0..3] of integer);
end; end;
PSockAddrIn6 = ^TSockAddrIn6; PSockAddrIn6 = ^TSockAddrIn6;

4
sswin32.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 002.000.001 | | Project : Ararat Synapse | 002.000.002 |
|==============================================================================| |==============================================================================|
| Content: Socket Independent Platform Layer - Win32 definition include | | Content: Socket Independent Platform Layer - Win32 definition include |
|==============================================================================| |==============================================================================|
@ -347,7 +347,7 @@ type
0: (S6_addr: packed array [0..15] of byte); 0: (S6_addr: packed array [0..15] of byte);
1: (u6_addr8: packed array [0..15] of byte); 1: (u6_addr8: packed array [0..15] of byte);
2: (u6_addr16: packed array [0..7] of word); 2: (u6_addr16: packed array [0..7] of word);
3: (u6_addr32: packed array [0..7] of integer); 3: (u6_addr32: packed array [0..3] of integer);
end; end;
PSockAddrIn6 = ^TSockAddrIn6; PSockAddrIn6 = ^TSockAddrIn6;

29
synachar.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 005.001.003 | | Project : Ararat Synapse | 005.002.002 |
|==============================================================================| |==============================================================================|
| Content: Charset conversion support | | Content: Charset conversion support |
|==============================================================================| |==============================================================================|
@ -66,7 +66,13 @@ interface
uses uses
{$IFNDEF WIN32} {$IFNDEF WIN32}
{$IFNDEF FPC}
Libc, Libc,
{$ELSE}
{$IFDEF FPC_USE_LIBC}
Libc,
{$ENDIF}
{$ENDIF}
{$ELSE} {$ELSE}
Windows, Windows,
{$ENDIF} {$ENDIF}
@ -153,6 +159,16 @@ var
{:By this you can generally disable/enable Iconv support.} {:By this you can generally disable/enable Iconv support.}
DisableIconv: Boolean = False; DisableIconv: Boolean = False;
{:Default set of charsets for @link(IdealCharsetCoding) function.}
IdealCharsets: TMimeSetChar =
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10,
KOI8_R, KOI8_U
{$IFNDEF CIL} //error URW778 ??? :-O
, GB2312, EUC_KR, ISO_2022_JP, EUC_TW
{$ENDIF}
];
{==============================================================================} {==============================================================================}
{:Convert Value from one charset to another. See: @link(CharsetConversionEx)} {:Convert Value from one charset to another. See: @link(CharsetConversionEx)}
function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar;
@ -1473,7 +1489,16 @@ end;
function GetCurCP: TMimeChar; function GetCurCP: TMimeChar;
begin begin
{$IFNDEF FPC}
Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME));
{$ELSE}
{$IFDEF FPC_USE_LIBC}
Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME));
{$ELSE}
//How to get system codepage without LIBC?
Result := UTF_8;
{$ENDIF}
{$ENDIF}
end; end;
function GetCurOEMCP: TMimeChar; function GetCurOEMCP: TMimeChar;
@ -1823,7 +1848,7 @@ begin
IconvArr[23].Charset := ISO_8859_7; IconvArr[23].Charset := ISO_8859_7;
IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK'; IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK';
IconvArr[24].Charset := ISO_8859_8; IconvArr[24].Charset := ISO_8859_8;
IconvArr[24].Charname := 'ISO_8859-8 HEBREW ISO-8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW'; IconvArr[24].Charname := 'ISO-8859-8 HEBREW ISO_8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW ISO-8859-8-I';
IconvArr[25].Charset := ISO_8859_9; IconvArr[25].Charset := ISO_8859_9;
IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5'; IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5';
IconvArr[26].Charset := ISO_8859_10; IconvArr[26].Charset := ISO_8859_10;

176
synacode.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 002.001.004 | | Project : Ararat Synapse | 002.002.000 |
|==============================================================================| |==============================================================================|
| Content: Coding and decoding support | | Content: Coding and decoding support |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | | Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -212,6 +212,9 @@ function HMAC_SHA1(Text, Key: AnsiString): AnsiString;
by repeating "value" until length is "Len".} by repeating "value" until length is "Len".}
function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString;
{:Returns a binary string with a RSA-MD4 hashing of "Value" string.}
function MD4(const Value: AnsiString): AnsiString;
implementation implementation
const const
@ -359,14 +362,11 @@ begin
end; end;
type type
TMD5Ctx = record TMDCtx = record
State: array[0..3] of Integer; State: array[0..3] of Integer;
Count: array[0..1] of Integer; Count: array[0..1] of Integer;
BufAnsiChar: array[0..63] of Byte; BufAnsiChar: array[0..63] of Byte;
BufLong: array[0..15] of Integer; BufLong: array[0..15] of Integer;
// case Integer of
// 0: (BufAnsiChar: array[0..63] of Byte);
// 1: (BufLong: array[0..15] of Integer);
end; end;
TSHA1Ctx= record TSHA1Ctx= record
Hi, Lo: integer; Hi, Lo: integer;
@ -374,11 +374,10 @@ type
Index: integer; Index: integer;
Hash: array[0..4] of Integer; Hash: array[0..4] of Integer;
HashByte: array[0..19] of byte; HashByte: array[0..19] of byte;
// case Integer of
// 0: (Hash: array[0..4] of Integer);
// 1: (HashByte: array[0..19] of byte);
end; end;
TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt);
{==============================================================================} {==============================================================================}
function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString;
@ -847,20 +846,20 @@ end;
{==============================================================================} {==============================================================================}
procedure MD5Init(var MD5Context: TMD5Ctx); procedure MDInit(var MDContext: TMDCtx);
var var
n: integer; n: integer;
begin begin
MD5Context.Count[0] := 0; MDContext.Count[0] := 0;
MD5Context.Count[1] := 0; MDContext.Count[1] := 0;
for n := 0 to high(MD5Context.BufAnsiChar) do for n := 0 to high(MDContext.BufAnsiChar) do
MD5Context.BufAnsiChar[n] := 0; MDContext.BufAnsiChar[n] := 0;
for n := 0 to high(MD5Context.BufLong) do for n := 0 to high(MDContext.BufLong) do
MD5Context.BufLong[n] := 0; MDContext.BufLong[n] := 0;
MD5Context.State[0] := Integer($67452301); MDContext.State[0] := Integer($67452301);
MD5Context.State[1] := Integer($EFCDAB89); MDContext.State[1] := Integer($EFCDAB89);
MD5Context.State[2] := Integer($98BADCFE); MDContext.State[2] := Integer($98BADCFE);
MD5Context.State[3] := Integer($10325476); MDContext.State[3] := Integer($10325476);
end; end;
procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt);
@ -975,7 +974,7 @@ begin
end; end;
//fixed by James McAdams //fixed by James McAdams
procedure MD5Update(var MD5Context: TMD5Ctx; const Data: AnsiString); procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform);
var var
Index, partLen, InputLen, I: integer; Index, partLen, InputLen, I: integer;
{$IFDEF CIL} {$IFDEF CIL}
@ -983,7 +982,7 @@ var
{$ENDIF} {$ENDIF}
begin begin
InputLen := Length(Data); InputLen := Length(Data);
with MD5Context do with MDContext do
begin begin
Index := (Count[0] shr 3) and $3F; Index := (Count[0] shr 3) and $3F;
Inc(Count[0], InputLen shl 3); Inc(Count[0], InputLen shl 3);
@ -1001,7 +1000,7 @@ begin
Move(Data[1], BufAnsiChar[Index], partLen); Move(Data[1], BufAnsiChar[Index], partLen);
{$ENDIF} {$ENDIF}
ArrByteToLong(BufAnsiChar, BufLong); ArrByteToLong(BufAnsiChar, BufLong);
MD5Transform(State, Buflong); Transform(State, Buflong);
I := partLen; I := partLen;
while I + 63 < InputLen do while I + 63 < InputLen do
begin begin
@ -1013,7 +1012,7 @@ begin
Move(Data[I+1], BufAnsiChar, 64); Move(Data[I+1], BufAnsiChar, 64);
{$ENDIF} {$ENDIF}
ArrByteToLong(BufAnsiChar, BufLong); ArrByteToLong(BufAnsiChar, BufLong);
MD5Transform(State, Buflong); Transform(State, Buflong);
inc(I, 64); inc(I, 64);
end; end;
Index := 0; Index := 0;
@ -1031,7 +1030,7 @@ begin
end end
end; end;
function MD5Final(var MD5Context: TMD5Ctx): AnsiString; function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString;
var var
Cnt: Word; Cnt: Word;
P: Byte; P: Byte;
@ -1041,7 +1040,7 @@ var
begin begin
for I := 0 to 15 do for I := 0 to 15 do
Digest[I] := I + 1; Digest[I] := I + 1;
with MD5Context do with MDContext do
begin begin
Cnt := (Count[0] shr 3) and $3F; Cnt := (Count[0] shr 3) and $3F;
P := Cnt; P := Cnt;
@ -1054,7 +1053,7 @@ begin
BufAnsiChar[P + n] := 0; BufAnsiChar[P + n] := 0;
ArrByteToLong(BufAnsiChar, BufLong); ArrByteToLong(BufAnsiChar, BufLong);
// FillChar(BufAnsiChar[P], Cnt, #0); // FillChar(BufAnsiChar[P], Cnt, #0);
MD5Transform(State, BufLong); Transform(State, BufLong);
ArrLongToByte(BufLong, BufAnsiChar); ArrLongToByte(BufLong, BufAnsiChar);
for n := 0 to 55 do for n := 0 to 55 do
BufAnsiChar[n] := 0; BufAnsiChar[n] := 0;
@ -1070,7 +1069,7 @@ begin
end; end;
BufLong[14] := Count[0]; BufLong[14] := Count[0];
BufLong[15] := Count[1]; BufLong[15] := Count[1];
MD5Transform(State, BufLong); Transform(State, BufLong);
ArrLongToByte(State, Digest); ArrLongToByte(State, Digest);
// Move(State, Digest, 16); // Move(State, Digest, 16);
Result := ''; Result := '';
@ -1084,11 +1083,11 @@ end;
function MD5(const Value: AnsiString): AnsiString; function MD5(const Value: AnsiString): AnsiString;
var var
MD5Context: TMD5Ctx; MDContext: TMDCtx;
begin begin
MD5Init(MD5Context); MDInit(MDContext);
MD5Update(MD5Context, Value); MDUpdate(MDContext, Value, @MD5Transform);
Result := MD5Final(MD5Context); Result := MDFinal(MDContext, @MD5Transform);
end; end;
{==============================================================================} {==============================================================================}
@ -1097,7 +1096,7 @@ function HMAC_MD5(Text, Key: AnsiString): AnsiString;
var var
ipad, opad, s: AnsiString; ipad, opad, s: AnsiString;
n: Integer; n: Integer;
MD5Context: TMD5Ctx; MDContext: TMDCtx;
begin begin
if Length(Key) > 64 then if Length(Key) > 64 then
Key := md5(Key); Key := md5(Key);
@ -1108,14 +1107,14 @@ begin
ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n]));
opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n]));
end; end;
MD5Init(MD5Context); MDInit(MDContext);
MD5Update(MD5Context, ipad); MDUpdate(MDContext, ipad, @MD5Transform);
MD5Update(MD5Context, Text); MDUpdate(MDContext, Text, @MD5Transform);
s := MD5Final(MD5Context); s := MDFinal(MDContext, @MD5Transform);
MD5Init(MD5Context); MDInit(MDContext);
MD5Update(MD5Context, opad); MDUpdate(MDContext, opad, @MD5Transform);
MD5Update(MD5Context, s); MDUpdate(MDContext, s, @MD5Transform);
Result := MD5Final(MD5Context); Result := MDFinal(MDContext, @MD5Transform);
end; end;
{==============================================================================} {==============================================================================}
@ -1125,17 +1124,17 @@ var
cnt, rest: integer; cnt, rest: integer;
l: integer; l: integer;
n: integer; n: integer;
MD5Context: TMD5Ctx; MDContext: TMDCtx;
begin begin
l := length(Value); l := length(Value);
cnt := Len div l; cnt := Len div l;
rest := Len mod l; rest := Len mod l;
MD5Init(MD5Context); MDInit(MDContext);
for n := 1 to cnt do for n := 1 to cnt do
MD5Update(MD5Context, Value); MDUpdate(MDContext, Value, @MD5Transform);
if rest > 0 then if rest > 0 then
MD5Update(MD5Context, Copy(Value, 1, rest)); MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform);
Result := MD5Final(MD5Context); Result := MDFinal(MDContext, @MD5Transform);
end; end;
{==============================================================================} {==============================================================================}
@ -1368,5 +1367,88 @@ end;
{==============================================================================} {==============================================================================}
procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt);
var
A, B, C, D: LongInt;
function LRot32(a, b: longint): longint;
begin
Result:= (a shl b) or (a shr (32 - b));
end;
begin
A := Buf[0];
B := Buf[1];
C := Buf[2];
D := Buf[3];
A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3);
D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7);
C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11);
B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19);
A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3);
D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7);
C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11);
B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19);
A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3);
D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7);
C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11);
B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19);
A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3);
D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7);
C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11);
B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19);
A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3);
D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5);
C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9);
B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13);
A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3);
D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5);
C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9);
B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13);
A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3);
D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5);
C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9);
B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13);
A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3);
D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5);
C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9);
B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13);
A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3);
D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9);
C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11);
B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15);
A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3);
D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9);
C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11);
B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15);
A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3);
D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9);
C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11);
B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15);
A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3);
D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9);
C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11);
B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15);
Inc(Buf[0], A);
Inc(Buf[1], B);
Inc(Buf[2], C);
Inc(Buf[3], D);
end;
{==============================================================================}
function MD4(const Value: AnsiString): AnsiString;
var
MDContext: TMDCtx;
begin
MDInit(MDContext);
MDUpdate(MDContext, Value, @MD4Transform);
Result := MDFinal(MDContext, @MD4Transform);
end;
{==============================================================================}
end. end.

1223
synacrypt.pas Normal file
View File

File diff suppressed because it is too large Load Diff

8
synafpc.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.001.000 | | Project : Ararat Synapse | 001.001.001 |
|==============================================================================| |==============================================================================|
| Content: Utils for FreePascal compatibility | | Content: Utils for FreePascal compatibility |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2006. | | Portions created by Lukas Gebauer are Copyright (c)2003-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -60,7 +60,7 @@ uses
{$IFDEF WIN32} {$IFDEF WIN32}
Windows; Windows;
{$ELSE} {$ELSE}
Sysutils; SysUtils;
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}

7
synaicnv.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.000.001 | | Project : Ararat Synapse | 001.000.002 |
|==============================================================================| |==============================================================================|
| Content: ICONV support for Win32, Linux and .NET | | Content: ICONV support for Win32, Linux and .NET |
|==============================================================================| |==============================================================================|
@ -64,7 +64,10 @@ uses
{$ENDIF} {$ENDIF}
synafpc, synafpc,
{$IFNDEF WIN32} {$IFNDEF WIN32}
Libc, SysUtils; {$IFNDEF FPC}
Libc,
{$ENDIF}
SysUtils;
{$ELSE} {$ELSE}
Windows; Windows;
{$ENDIF} {$ENDIF}

17
synaip.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.000.000 | | Project : Ararat Synapse | 001.000.002 |
|==============================================================================| |==============================================================================|
| Content: IP address support procedures and functions | | Content: IP address support procedures and functions |
|==============================================================================| |==============================================================================|
@ -218,8 +218,8 @@ var
y1, y2: byte; y1, y2: byte;
begin begin
Result := ''; Result := '';
x1 := value div $10000; x1 := value shr 16;
x2 := value mod $10000; x2 := value and $FFFF;
y1 := x1 div $100; y1 := x1 div $100;
y2 := x1 mod $100; y2 := x1 mod $100;
Result := inttostr(y1) + '.' + inttostr(y2) + '.'; Result := inttostr(y1) + '.' + inttostr(y2) + '.';
@ -379,11 +379,18 @@ function ReverseIP6(Value: AnsiString): AnsiString;
var var
ip6: TIp6bytes; ip6: TIp6bytes;
n: integer; n: integer;
x, y: integer;
begin begin
ip6 := StrToIP6(Value); ip6 := StrToIP6(Value);
Result := char(ip6[15]); x := ip6[15] div 16;
y := ip6[15] mod 16;
Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
for n := 14 downto 0 do for n := 14 downto 0 do
Result := Result + '.' + char(ip6[n]); begin
x := ip6[n] div 16;
y := ip6[n] mod 16;
Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
end;
end; end;
{==============================================================================} {==============================================================================}

35
synautil.pas
View File

@ -1,5 +1,5 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 004.010.001 | | Project : Ararat Synapse | 004.011.003 |
|==============================================================================| |==============================================================================|
| Content: support procedures and functions | | Content: support procedures and functions |
|==============================================================================| |==============================================================================|
@ -302,6 +302,10 @@ procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
directory is used) and with optional filename prefix.} directory is used) and with optional filename prefix.}
function GetTempFile(const Dir, prefix: AnsiString): AnsiString; function GetTempFile(const Dir, prefix: AnsiString): AnsiString;
{:Return padded string. If length is greater, string is truncated. If length is
smaller, string is padded by Pad character.}
function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString;
var var
{:can be used for your own months strings for @link(getmonthnumber)} {:can be used for your own months strings for @link(getmonthnumber)}
CustomMonthNames: array[1..12] of string; CustomMonthNames: array[1..12] of string;
@ -664,10 +668,15 @@ begin
end; end;
if year = 0 then if year = 0 then
year := 1980; year := 1980;
if (month < 1) or (month > 12) then if month < 1 then
month := 1; month := 1;
if (day < 1) or (day > 31) then if month > 12 then
month := 12;
if day < 1 then
day := 1; day := 1;
x := MonthDays[IsLeapYear(year), month];
if day > x then
day := x;
Result := Result + Encodedate(year, month, day); Result := Result + Encodedate(year, month, day);
zone := zone - TimeZoneBias; zone := zone - TimeZoneBias;
x := zone div 1440; x := zone div 1440;
@ -1394,10 +1403,12 @@ begin
Result := False; Result := False;
for n := 1 to Length(Value) do for n := 1 to Length(Value) do
if Value[n] in [#0..#8, #10..#31] then if Value[n] in [#0..#8, #10..#31] then
begin //ignore null-terminated strings
Result := True; if not ((n = Length(value)) and (Value[n] = #0)) then
Break; begin
end; Result := True;
Break;
end;
end; end;
{==============================================================================} {==============================================================================}
@ -1736,6 +1747,16 @@ begin
{$ENDIF} {$ENDIF}
end; end;
{==============================================================================}
function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString;
begin
if length(value) >= len then
Result := Copy(value, 1, len)
else
Result := Value + StringOfChar(Pad, len - length(value));
end;
{==============================================================================} {==============================================================================}
var var
n: integer; n: integer;

8
tlntsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.002.000 | | Project : Ararat Synapse | 001.002.001 |
|==============================================================================| |==============================================================================|
| Content: TELNET and SSH2 client | | Content: TELNET and SSH2 client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer | | Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2005. | | Portions created by Lukas Gebauer are Copyright (c)2002-2007. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -61,7 +61,7 @@ uses
blcksock, synautil; blcksock, synautil;
const const
cTelnetProtocol = 'telnet'; cTelnetProtocol = '23';
cSSHProtocol = '22'; cSSHProtocol = '22';
TLNT_EOR = #239; TLNT_EOR = #239;