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 |
|==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -99,7 +99,7 @@ uses
const
SynapseRelease = '37';
SynapseRelease = '38';
cLocalhost = '127.0.0.1';
cAnyHost = '0.0.0.0';
@ -188,6 +188,15 @@ type
THookMonitor = procedure(Sender: TObject; Writing: Boolean;
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.}
TSocketFamily = (
{:Default mode. Socket family is defined by target address for connection.
@ -254,6 +263,7 @@ type
FOnReadFilter: THookDataFilter;
FOnCreateSocket: THookCreateSocket;
FOnMonitor: THookMonitor;
FOnHeartbeat: THookHeartbeat;
FLocalSin: TVarSin;
FRemoteSin: TVarSin;
FTag: integer;
@ -282,6 +292,8 @@ type
FSendCounter: Integer;
FSendMaxChunk: Integer;
FStopFlag: Boolean;
FNonblockSendTimeout: Integer;
FHeartbeatRate: integer;
function GetSizeRecvBuffer: Integer;
procedure SetSizeRecvBuffer(Size: Integer);
function GetSizeSendBuffer: Integer;
@ -308,10 +320,12 @@ type
procedure DoReadFilter(Buffer: TMemory; var Len: Integer);
procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
procedure DoCreateSocket;
procedure DoHeartbeat;
procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
procedure SetBandwidth(Value: Integer);
function TestStopFlag: Boolean;
procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual;
function InternalCanRead(Timeout: Integer): Boolean; virtual;
public
constructor Create;
@ -537,10 +551,13 @@ type
{:Actualize values in @link(LocalSin) and @link(RemoteSin).}
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
parameter to this function, which evaluates it, eventually calls
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)
property is @true, raise adequate exception.}
@ -590,7 +607,8 @@ type
data maybe forever.
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;
{: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!}
class function GetErrorDesc(ErrorCode: Integer): string;
{:Return descriptive string for @link(LastError).}
function GetErrorDescEx: string; virtual;
{:this value is for free use.}
property Tag: Integer read FTag write FTag;
@ -770,6 +791,9 @@ type
use this property for soft abort of communication.}
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,
create gauges for data transfers, etc.}
property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
@ -785,6 +809,18 @@ type
{:This event is good for monitoring content of readed or writed datas.}
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;
{:@abstract(Support for SOCKS4 and SOCKS5 proxy)
@ -865,6 +901,7 @@ type
(outgoing connections and limited incomming), TCP through HTTP proxy tunnel.}
TTCPBlockSocket = class(TSocksBlockSocket)
protected
FOnAfterConnect: THookAfterConnect;
FSSL: TCustomSSL;
FHTTPTunnelIP: string;
FHTTPTunnelPort: string;
@ -876,6 +913,7 @@ type
FHTTPTunnelTimeout: integer;
procedure SocksDoConnect(IP, Port: string);
procedure HTTPTunnelDoConnect(IP, Port: string);
procedure DoAfterConnect;
public
{:Create TCP socket class with default plugin for SSL/TSL/SSH implementation
(see @link(SSLImplementation))}
@ -885,6 +923,10 @@ type
constructor CreateWithSSL(SSLPlugin: TSSLClass);
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)}
procedure CloseSocket; override;
@ -994,6 +1036,9 @@ type
{:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.}
property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout;
{:This event is called after sucessful TCP socket connection.}
property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect;
end;
{:@abstract(Datagram based communication)
@ -1410,6 +1455,8 @@ begin
FSendCounter := 0;
FSendMaxChunk := c64k;
FStopFlag := False;
FNonblockSendTimeout := 15000;
FHeartbeatRate := 0;
{$IFNDEF ONCEWINSOCK}
if Stub = '' then
Stub := DLLStackName;
@ -1615,7 +1662,7 @@ var
f: TSocketFamily;
begin
DoStatus(HR_ResolvingBegin, IP + ':' + Port);
FLastError := 0;
ResetLastError;
//if socket exists, then use their type, else use users selection
f := SF_Any;
if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then
@ -1648,7 +1695,7 @@ var
sin: TVarSin;
begin
//dummy for SF_Any Family mode
FLastError := 0;
ResetLastError;
if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then
begin
{$IFDEF CIL}
@ -1671,7 +1718,7 @@ procedure TBlockSocket.CreateSocketByName(const Value: String);
var
sin: TVarSin;
begin
FLastError := 0;
ResetLastError;
if FSocket = INVALID_SOCKET then
begin
SetSin(sin, value, '0');
@ -1685,7 +1732,7 @@ begin
FStopFlag := False;
FRecvCounter := 0;
FSendCounter := 0;
FLastError := 0;
ResetLastError;
if FSocket = INVALID_SOCKET then
begin
FBuffer := '';
@ -1728,7 +1775,6 @@ begin
end;
FDelayedOptions.Clear;
FFamily := FFamilySave;
FLastError := 0;
DoStatus(HR_SocketClose, '');
end;
@ -1736,7 +1782,7 @@ procedure TBlockSocket.Bind(IP, Port: string);
var
Sin: TVarSin;
begin
FLastError := 0;
ResetLastError;
if (FSocket <> INVALID_SOCKET)
or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then
begin
@ -1801,7 +1847,10 @@ procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next:
var
x: LongWord;
y: LongWord;
n: integer;
begin
if FStopFlag then
exit;
if MaxB > 0 then
begin
y := GetTick;
@ -1811,7 +1860,12 @@ begin
if x > 0 then
begin
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;
Next := GetTick + Trunc((Length / MaxB) * 1000);
@ -1820,6 +1874,7 @@ end;
function TBlockSocket.TestStopFlag: Boolean;
begin
DoHeartbeat;
Result := FStopFlag;
if Result then
begin
@ -1856,10 +1911,19 @@ begin
begin
LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
p := IncPoint(Buffer, x);
// r := synsock.Send(FSocket, p^, y, MSG_NOSIGNAL);
r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
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;
Inc(x, r);
Inc(Result, r);
@ -2031,7 +2095,7 @@ var
b: TMemory;
{$ENDIF}
begin
FLastError := 0;
ResetLastError;
Result := 0;
if Len > 0 then
begin
@ -2109,7 +2173,7 @@ var
{$ENDIF}
begin
Result := '';
FLastError := 0;
ResetLastError;
if FBuffer <> '' then
begin
Result := FBuffer;
@ -2184,7 +2248,7 @@ end;
function TBlockSocket.RecvByte(Timeout: Integer): Byte;
begin
Result := 0;
FLastError := 0;
ResetLastError;
if FBuffer = '' then
FBuffer := RecvPacket(Timeout);
if (FLastError = 0) and (FBuffer <> '') then
@ -2215,7 +2279,7 @@ var
tl: integer;
ti: LongWord;
begin
FLastError := 0;
ResetLastError;
Result := '';
l := Length(Terminator);
if l = 0 then
@ -2393,24 +2457,28 @@ begin
{$ENDIF}
end;
procedure TBlockSocket.ResetLastError;
begin
FLastError := 0;
FLastErrorDesc := '';
end;
function TBlockSocket.SockCheck(SockResult: Integer): Integer;
begin
FLastErrorDesc := '';
ResetLastError;
if SockResult = integer(SOCKET_ERROR) then
begin
Result := synsock.WSAGetLastError;
FLastErrorDesc := GetErrorDesc(Result);
end
else
Result := 0;
FLastError := Result;
FLastError := synsock.WSAGetLastError;
FLastErrorDesc := GetErrorDescEx;
end;
Result := FLastError;
end;
procedure TBlockSocket.ExceptCheck;
var
e: ESynapseError;
begin
FLastErrorDesc := GetErrorDesc(FLastError);
FLastErrorDesc := GetErrorDescEx;
if (LastError <> 0) and (LastError <> WSAEINPROGRESS)
and (LastError <> WSAEWOULDBLOCK) then
begin
@ -2419,8 +2487,6 @@ begin
begin
e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s',
[FLastError, FLastErrorDesc]));
// e := ESynapseError.CreateFmt('Synapse TCP/IP Socket error %d: %s',
// [FLastError, FLastErrorDesc]);
e.ErrorCode := FLastError;
e.ErrorMessage := FLastErrorDesc;
raise e;
@ -2460,7 +2526,7 @@ begin
except
on exception do;
end;
FLastError := 0;
ResetLastError;
end;
procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer);
@ -2539,7 +2605,7 @@ begin
Result := GetSinPort(FRemoteSin);
end;
function TBlockSocket.CanRead(Timeout: Integer): Boolean;
function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean;
{$IFDEF CIL}
begin
Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead);
@ -2562,6 +2628,38 @@ begin
x := 0;
Result := x > 0;
{$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;
if Result then
DoStatus(HR_CanRead, '');
@ -2878,6 +2976,19 @@ begin
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;
begin
{$IFDEF CIL}
@ -3399,7 +3510,7 @@ begin
end
else
begin
Multicast.imr_multiaddr.S_addr := strtoip(MCastIP);
Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
Multicast.imr_interface.S_addr := INADDR_ANY;
SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP,
pchar(@Multicast), SizeOf(Multicast)));
@ -3425,7 +3536,7 @@ begin
end
else
begin
Multicast.imr_multiaddr.S_addr := strtoip(MCastIP);
Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
Multicast.imr_interface.S_addr := INADDR_ANY;
SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP,
pchar(@Multicast), SizeOf(Multicast)));
@ -3503,11 +3614,20 @@ begin
FSSL.Free;
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;
begin
if FSSL.SSLEnabled then
FSSL.Shutdown;
if FSocket <> INVALID_SOCKET then
if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then
begin
Synsock.Shutdown(FSocket, 1);
Purge;
@ -3515,6 +3635,14 @@ begin
inherited CloseSocket;
end;
procedure TTCPBlockSocket.DoAfterConnect;
begin
if assigned(OnAfterConnect) then
begin
OnAfterConnect(Self);
end;
end;
function TTCPBlockSocket.WaitingData: Integer;
begin
Result := 0;
@ -3587,6 +3715,8 @@ begin
HTTPTunnelDoConnect(IP, Port)
else
inherited Connect(IP, Port);
if FLasterror = 0 then
DoAfterConnect;
end;
procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string);
@ -3645,7 +3775,7 @@ end;
procedure TTCPBlockSocket.SSLDoConnect;
begin
FLastError := 0;
ResetLastError;
if not FSSL.Connect then
FLastError := WSASYSNOTREADY;
ExceptCheck;
@ -3653,7 +3783,7 @@ end;
procedure TTCPBlockSocket.SSLDoShutdown;
begin
FLastError := 0;
ResetLastError;
FSSL.BiShutdown;
end;
@ -3702,7 +3832,8 @@ begin
Result := 0;
if TestStopFlag then
Exit;
FLastError := 0;
ResetLastError;
LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv);
Result := FSSL.RecvBuffer(Buffer, Len);
if FSSL.LastError <> 0 then
FLastError := WSASYSNOTREADY;
@ -3729,7 +3860,7 @@ begin
Result := 0;
if TestStopFlag then
Exit;
FLastError := 0;
ResetLastError;
DoMonitor(True, Buffer, Length);
{$IFDEF CIL}
Result := FSSL.SendBuffer(Buffer, Length);
@ -3771,7 +3902,7 @@ end;
function TTCPBlockSocket.SSLAcceptConnection: Boolean;
begin
FLastError := 0;
ResetLastError;
if not FSSL.Accept then
FLastError := WSASYSNOTREADY;
ExceptCheck;
@ -3881,7 +4012,7 @@ end;
procedure TCustomSSL.ReturnError;
begin
FLastError := -1;
FLastErrorDesc := 'SLL is not implemented!';
FLastErrorDesc := 'SSL/TLS support is not compiled!';
end;
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 |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -63,7 +63,7 @@ uses
blcksock, synautil, synaip, synsock;
const
cDnsProtocol = 'domain';
cDnsProtocol = '53';
QTYPE_A = 1;
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 |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -62,8 +62,8 @@ uses
blcksock, synautil, synaip, synsock;
const
cFtpProtocol = 'ftp';
cFtpDataProtocol = 'ftp-data';
cFtpProtocol = '21';
cFtpDataProtocol = '20';
{:Terminating value for TLogonActions}
FTP_OK = 255;
@ -314,6 +314,9 @@ type
function ChangeWorkingDir(const Directory: string): Boolean; virtual;
{: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;
{:Delete Directory on FTP server.}
@ -872,7 +875,7 @@ begin
FDSock.Bind(FSock.GetLocalSinIP, s);
if FDSock.LastError <> 0 then
Exit;
FDSock.SetLinger(True, 10);
FDSock.SetLinger(True, 10000);
FDSock.Listen;
FDSock.GetSins;
FDataIP := FDSock.GetLocalSinIP;
@ -1143,11 +1146,16 @@ begin
Result := (FTPCommand('CWD ' + Directory) div 100) = 2;
end;
function TFTPSend.ChangeToRootDir: Boolean;
function TFTPSend.ChangeToParentDir: Boolean;
begin
Result := (FTPCommand('CDUP') div 100) = 2;
end;
function TFTPSend.ChangeToRootDir: Boolean;
begin
Result := ChangeWorkingDir('/');
end;
function TFTPSend.DeleteDir(const Directory: string): Boolean;
begin
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 |
|==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -93,6 +93,7 @@ type
FUploadSize: integer;
FRangeStart: integer;
FRangeEnd: integer;
FAddPortNumberToHost: Boolean;
function ReadUnknown: Boolean;
function ReadIdentity(Size: Integer): Boolean;
function ReadChunked: Boolean;
@ -203,6 +204,10 @@ type
property UploadSize: integer read FUploadSize;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
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;
{: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)';
FDownloadSize := 0;
FUploadSize := 0;
FAddPortNumberToHost := true;
Clear;
end;
@ -407,7 +413,7 @@ begin
if FUserAgent <> '' then
FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
{ setting Ranges }
if FRangeStart > 0 then
if (FRangeStart > 0) or (FRangeEnd > 0) then
begin
if FRangeEnd >= FRangeStart then
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd))
@ -437,7 +443,7 @@ begin
s := '[' + Host + ']'
else
s := Host;
if Port<>'80' then
if FAddPortNumberToHost and (Port <> '80') then
FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
else
FHeaders.Insert(0, 'Host: ' + s);
@ -465,7 +471,6 @@ begin
{ connect }
if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
begin
FSock.CloseSocket;
FAliveHost := '';
FAlivePort := '';
Exit;
@ -538,18 +543,20 @@ begin
if s <> '' then
Break;
until FSock.LastError <> 0;
if Pos('HTTP/', UpperCase(s)) = 1 then
begin
FHeaders.Add(s);
DecodeStatus(s);
end
else
begin
{ old HTTP 0.9 and some buggy servers not send result }
s := s + CRLF;
WriteStrToStream(FDocument, s);
FResultCode := 0;
end;
repeat
if Pos('HTTP/', UpperCase(s)) = 1 then
begin
FHeaders.Add(s);
DecodeStatus(s);
end
else
begin
{ old HTTP 0.9 and some buggy servers not send result }
s := s + CRLF;
WriteStrToStream(FDocument, s);
FResultCode := 0;
end;
until (FSock.LastError <> 0) or (FResultCode <> 100);
end
else
FHeaders.Add(Status100Error);
@ -566,7 +573,7 @@ begin
if Pos('CONTENT-LENGTH:', su) = 1 then
begin
Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
if Size <> -1 then
if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
FTransferEncoding := TE_IDENTITY;
end;
if Pos('CONTENT-TYPE:', su) = 1 then
@ -612,12 +619,17 @@ function THTTPSend.ReadUnknown: Boolean;
var
s: string;
begin
Result := false;
repeat
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
WriteStrToStream(FDocument, s);
until FSock.LastError <> 0;
Result := FSock.LastError = WSAECONNRESET;
if FSock.LastError = WSAECONNRESET then
begin
Result := true;
FSock.ResetLastError;
end;
end;
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
@ -719,6 +731,7 @@ begin
HTTP.Document.CopyFrom(Data, 0);
HTTP.MimeType := 'Application/octet-stream';
Result := HTTP.HTTPMethod('POST', URL);
Data.Size := 0;
if Result then
begin
Data.Seek(0, soFromBeginning);

4
imapsend.pas
View File

@ -177,8 +177,8 @@ type
{:Append given message to specified folder.}
function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
{:'Delete' message from currect selected folder. It mark message as Deleted.
Real deleting waill be done after sucessfull @link(CloseFolder) or
{:'Delete' message from current selected folder. It mark message as Deleted.
Real deleting will be done after sucessfull @link(CloseFolder) or
@link(ExpungeFolder)}
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 |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2006, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -220,14 +220,7 @@ var
begin
if NeedInline(Value) then
begin
c := IdealCharsetCoding(Value, FromCP,
[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}
]);
c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
Result := InlineEncode(Value, FromCP, c);
end
else
@ -252,7 +245,7 @@ begin
if sd = '' then
Result := se
else
Result := '"' + InlineCodeEx(sd, FromCP) + '"<' + se + '>';
Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
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 |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| Copyright (c)1999-2006, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -90,7 +90,7 @@ type
destructor Destroy; override;
{:Clears all data fields.}
procedure Clear;
procedure Clear; virtual;
{Add headers from from this object to Value.}
procedure EncodeHeaders(const Value: TStrings); virtual;
@ -171,7 +171,7 @@ type
destructor Destroy; override;
{:Reset component to default state.}
procedure Clear;
procedure Clear; virtual;
{: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,
@ -362,7 +362,7 @@ begin
if s = '' then
s := InlineEmailEx(FCCList[n], FCharsetCode)
else
s := s + ' , ' + InlineEmailEx(FCCList[n], FCharsetCode);
s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode);
if s <> '' then
Value.Insert(0, 'CC: ' + s);
Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
@ -373,7 +373,7 @@ begin
if s = '' then
s := InlineEmailEx(FToList[n], FCharsetCode)
else
s := s + ' , ' + InlineEmailEx(FToList[n], FCharsetCode);
s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode);
if s <> '' then
Value.Insert(0, 'To: ' + s);
Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
@ -624,14 +624,7 @@ begin
Secondary := 'plain';
Description := 'Message text';
Disposition := 'inline';
CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset,
[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}
]);
CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets);
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
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 |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -733,7 +733,7 @@ end;
procedure TMIMEPart.DecodePart;
var
n: Integer;
s, t: string;
s, t, t2: string;
b: Boolean;
begin
FDecodedLines.Clear;
@ -758,8 +758,8 @@ begin
if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then
begin
b := false;
t := uppercase(s);
t := SeparateLeft(t, '</HEAD>');
t2 := uppercase(s);
t := SeparateLeft(t2, '</HEAD>');
if length(t) <> length(s) then
begin
t := SeparateRight(t, '<HEAD>');
@ -767,6 +767,15 @@ begin
t := ReplaceString(t, ' ', '');
b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
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
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end
@ -1067,8 +1076,11 @@ end;
procedure TMIMEPart.SetCharset(Value: string);
begin
FCharset := Value;
FCharsetCode := GetCPFromID(Value);
if value <> '' then
begin
FCharset := Value;
FCharsetCode := GetCPFromID(Value);
end;
end;
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 |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -62,7 +62,7 @@ uses
blcksock, synautil;
const
cNNTPProtocol = 'nntp';
cNNTPProtocol = '119';
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 |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -45,11 +45,15 @@
{:@abstract(ICMP PING implementation.)
Allows create PING and TRACEROUTE. Or you can diagnose your network.
Warning: this unit using RAW sockets. On some systems you must have special
rights for using this sort of sockets. So, it working allways when you have
administator/root rights. Otherwise you can have problems!
This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying
to use RAW sockets.
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}
@ -69,7 +73,11 @@ interface
uses
SysUtils,
synsock, blcksock, synautil;
synsock, blcksock, synautil, synafpc, synaip
{$IFDEF WIN32}
, windows
{$ENDIF}
;
const
ICMP_ECHO = 8;
@ -83,28 +91,6 @@ const
ICMP6_TIME_EXCEEDED = 3;
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.}
TICMPError = (
IE_NoError,
@ -117,10 +103,7 @@ type
IE_UnreachPort
);
{:@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!}
{:@abstract(Implementation of ICMP PING and ICMPv6 PING.)}
TPINGSend = class(TSynaClient)
private
FSock: TICMPBlockSocket;
@ -137,10 +120,17 @@ type
FReplyCode: byte;
FReplyError: TICMPError;
FReplyErrorDesc: string;
FTTL: Byte;
Fsin: TVarSin;
function Checksum(Value: string): Word;
function Checksum6(Value: string): Word;
function ReadPacket: Boolean;
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
{:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
@true.}
@ -176,6 +166,9 @@ type
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TICMPBlockSocket read FSock;
{:TTL value for ICMP query}
property TTL: byte read FTTL write FTTL;
end;
{: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
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;
@ -199,6 +268,7 @@ begin
FPacketSize := 32;
FSeq := 0;
Randomize;
FTTL := 128;
end;
destructor TPINGSend.Destroy;
@ -213,7 +283,69 @@ begin
Result := FSock.LastError = 0;
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;
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
IPHeadPtr: ^TIPHeader;
IpHdrLen: Integer;
@ -223,12 +355,7 @@ var
IcmpReqHead: string;
begin
Result := False;
FPingTime := -1;
FReplyFrom := '';
FReplyType := 0;
FReplyCode := 0;
FReplyError := IE_NoError;
FReplyErrorDesc := '';
FSock.TTL := FTTL;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(Host, '0');
if FSock.LastError <> 0 then
@ -246,7 +373,6 @@ begin
FIcmpEchoReply := ICMP_ECHOREPLY;
FIcmpUnreach := ICMP_UNREACH;
end;
FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
IcmpEchoHeaderPtr := Pointer(FBuffer);
with IcmpEchoHeaderPtr^ do
begin
@ -414,25 +540,96 @@ begin
FReplyError := IE_Other;
end;
end;
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';
GenErrorDesc;
end;
procedure TPINGSend.TranslateErrorIpHlp(value: integer);
begin
case value of
11000, 0:
FReplyError := IE_NoError;
11013:
FReplyError := IE_TTLExceed;
11002:
FReplyError := IE_UnreachRoute;
11003:
FReplyError := IE_UnreachAddr;
11005:
FReplyError := IE_UnreachPort;
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;
{$ELSE}
begin
result := false;
end;
{$ENDIF}
{==============================================================================}
@ -459,7 +656,7 @@ begin
try
ttl := 1;
repeat
ping.Sock.TTL := ttl;
ping.TTL := ttl;
inc(ttl);
if ttl > 30 then
Break;
@ -481,4 +678,31 @@ begin
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.

87
pop3send.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.005.000 |
| Project : Ararat Synapse | 002.006.000 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -61,7 +61,7 @@ uses
blcksock, synautil, synacode;
const
cPop3Protocol = 'pop3';
cPop3Protocol = '110';
type
@ -98,6 +98,11 @@ type
constructor Create;
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.
note: not all servers support this command!}
function Capability: Boolean;
@ -237,17 +242,25 @@ begin
Delete(s, 1, 1);
FFullResult.Add(s);
until FSock.LastError <> 0;
if not Full and (Result = 1) then
FFullResult.Add(SeparateRight(FResultString, ' '));
if FSock.LastError <> 0 then
Result := 0;
FResultCode := Result;
end;
function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
begin
FSock.SendString(Command + CRLF);
Result := ReadResult(MultiLine) <> 0;
end;
function TPOP3Send.AuthLogin: Boolean;
begin
Result := False;
FSock.SendString('USER ' + FUserName + CRLF);
if ReadResult(False) <> 1 then
Exit;
FSock.SendString('PASS ' + FPassword + CRLF);
Result := ReadResult(False) = 1;
if not CustomCommand('USER ' + FUserName, False) then
exit;
Result := CustomCommand('PASS ' + FPassword, False)
end;
function TPOP3Send.AuthAPOP: Boolean;
@ -255,8 +268,7 @@ var
s: string;
begin
s := StrToHex(MD5(FTimeStamp + FPassWord));
FSock.SendString('APOP ' + FUserName + ' ' + s + CRLF);
Result := ReadResult(False) = 1;
Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
end;
function TPOP3Send.Connect: Boolean;
@ -278,8 +290,7 @@ end;
function TPOP3Send.Capability: Boolean;
begin
FPOP3cap.Clear;
FSock.SendString('CAPA' + CRLF);
Result := ReadResult(True) = 1;
Result := CustomCommand('CAPA', True);
if Result then
FPOP3cap.AddStrings(FFullResult);
end;
@ -328,35 +339,31 @@ end;
function TPOP3Send.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
Result := ReadResult(False) = 1;
Result := CustomCommand('QUIT', False);
FSock.CloseSocket;
end;
function TPOP3Send.Reset: Boolean;
begin
FSock.SendString('RSET' + CRLF);
Result := ReadResult(False) = 1;
Result := CustomCommand('RSET', False);
end;
function TPOP3Send.NoOp: Boolean;
begin
FSock.SendString('NOOP' + CRLF);
Result := ReadResult(False) = 1;
Result := CustomCommand('NOOP', False);
end;
function TPOP3Send.Stat: Boolean;
var
s: string;
begin
Result := False;
FSock.SendString('STAT' + CRLF);
if ReadResult(False) <> 1 then
Exit;
s := SeparateRight(ResultString, '+OK ');
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
Result := True;
Result := CustomCommand('STAT', False);
if Result then
begin
s := SeparateRight(ResultString, '+OK ');
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
end;
end;
function TPOP3Send.List(Value: Integer): Boolean;
@ -365,10 +372,10 @@ var
n: integer;
begin
if Value = 0 then
FSock.SendString('LIST' + CRLF)
s := 'LIST'
else
FSock.SendString('LIST ' + IntToStr(Value) + CRLF);
Result := ReadResult(Value = 0) = 1;
s := 'LIST ' + IntToStr(Value);
Result := CustomCommand(s, Value = 0);
FListSize := 0;
if Result then
if Value <> 0 then
@ -383,8 +390,7 @@ end;
function TPOP3Send.Retr(Value: Integer): Boolean;
begin
FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
Result := ReadResult(True) = 1;
Result := CustomCommand('RETR ' + IntToStr(Value), True);
end;
//based on code by Miha Vrhovnik
@ -423,30 +429,29 @@ end;
function TPOP3Send.Dele(Value: Integer): Boolean;
begin
FSock.SendString('DELE ' + IntToStr(Value) + CRLF);
Result := ReadResult(False) = 1;
Result := CustomCommand('DELE ' + IntToStr(Value), False);
end;
function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
begin
FSock.SendString('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines) + CRLF);
Result := ReadResult(True) = 1;
Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
end;
function TPOP3Send.Uidl(Value: Integer): Boolean;
var
s: string;
begin
if Value = 0 then
FSock.SendString('UIDL' + CRLF)
s := 'UIDL'
else
FSock.SendString('UIDL ' + IntToStr(Value) + CRLF);
Result := ReadResult(Value = 0) = 1;
s := 'UIDL ' + IntToStr(Value);
Result := CustomCommand(s, Value = 0);
end;
function TPOP3Send.StartTLS: Boolean;
begin
Result := False;
FSock.SendString('STLS' + CRLF);
if ReadResult(False) = 1 then
if CustomCommand('STLS', False) then
begin
Fsock.SSLDoConnect;
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 |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -62,7 +62,7 @@ uses
blcksock, synautil, synacode;
const
cSmtpProtocol = 'smtp';
cSmtpProtocol = '25';
type
{:@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 |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -679,6 +679,7 @@ begin
ASNObject(Self.FCommunity, ASN1_OCTSTR);
Result := ASNObject(head + pdu, ASN1_SEQ);
end;
inc(self.FID);
end;
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 |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -63,7 +63,7 @@ uses
synsock, blcksock, synautil;
const
cNtpProtocol = 'ntp';
cNtpProtocol = '123';
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 |
|==============================================================================|
@ -83,6 +83,8 @@ const
cLocalHost = '127.0.0.1';
cAnyHost = '0.0.0.0';
c6AnyHost = '::0';
c6Localhost = '::1';
cLocalHostStr = 'localhost';
type
TSocket = longint;
@ -675,11 +677,16 @@ var
end
else
begin
a4[1].s_addr := 0;
Result := WSAHOST_NOT_FOUND;
a4[1] := StrTonetAddr(IP);
if a4[1].s_addr = INADDR_ANY then
Resolvename(ip, a4);
if lowercase(IP) = cLocalHostStr then
a4[1].s_addr := htonl(INADDR_LOOPBACK)
else
begin
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
begin
Sin.sin_family := AF_INET;
@ -697,11 +704,16 @@ var
end
else
begin
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);
if lowercase(IP) = cLocalHostStr then
SET_LOOPBACK_ADDR6(@a6[1])
else
begin
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
begin
Sin.sin_family := AF_INET6;
@ -772,26 +784,36 @@ begin
IPList.Clear;
if (family = AF_INET) or (family = AF_UNSPEC) then
begin
a4[1] := StrTonetAddr(name);
if a4[1].s_addr = INADDR_ANY then
x := Resolvename(name, a4)
if lowercase(name) = cLocalHostStr then
IpList.Add(cLocalHost)
else
x := 1;
for n := 1 to x do
IpList.Add(netaddrToStr(a4[n]));
begin
a4[1] := StrTonetAddr(name);
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;
if (family = AF_INET6) or (family = AF_UNSPEC) then
begin
a6[1] := StrTonetAddr6(name);
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
x := Resolvename6(name, a6)
if lowercase(name) = cLocalHostStr then
IpList.Add(c6LocalHost)
else
x := 1;
for n := 1 to x do
IpList.Add(netaddrToStr6(a6[n]));
begin
a6[1] := StrTonetAddr6(name);
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;
if IPList.Count = 0 then
IPList.Add(cLocalHost);
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 |
|==============================================================================|
@ -98,6 +98,7 @@ type
FSlave: TMyTLSSynSockSlave;
FIsServer: Boolean;
FTLSServer: TCustomTLSInternalServer;
FServerCreated: Boolean;
function SSLCheck: Boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
@ -204,7 +205,7 @@ end;
function TSSLStreamSec.Init(server:Boolean): Boolean;
var
st: TMemoryStream;
pass: TSecretKey;
pass: ISecretKey;
ws: WideString;
begin
Result := False;
@ -218,8 +219,10 @@ begin
else
if Assigned(TLSInternalServer.GlobalServer) then
FSlave.MyTLSServer := TLSInternalServer.GlobalServer
else
else begin
FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
FServerCreated := True;
end;
if server then
FSlave.MyTLSServer.ClientOrServer := cosServerSide
else
@ -293,7 +296,7 @@ begin
end;
if FPFXfile <> '' then
FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
if server then
if server and FServerCreated then
begin
FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
@ -306,17 +309,24 @@ begin
end;
Result := true;
finally
pass.Free;
pass := nil;
end;
end;
function TSSLStreamSec.DeInit: Boolean;
var
obj: TObject;
begin
Result := True;
if assigned(FSlave) then
begin
FSlave.Close;
if FServerCreated then
obj := FSlave.TLSServer
else
obj := nil;
FSlave.Free;
obj.Free;
FSlave := nil;
end;
FSSLEnabled := false;
@ -355,7 +365,7 @@ begin
Exit;
if Prepare(true) then
begin
FSlave.Open;
FSlave.DoConnect;
SSLCheck;
if FLastError <> 0 then
Exit;
@ -526,3 +536,4 @@ finalization
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 |
|==============================================================================|
@ -163,7 +163,7 @@ type
0: (S6_addr: packed array [0..15] of byte);
1: (u6_addr8: packed array [0..15] of byte);
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;
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 |
|==============================================================================|
@ -347,7 +347,7 @@ type
0: (S6_addr: packed array [0..15] of byte);
1: (u6_addr8: packed array [0..15] of byte);
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;
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 |
|==============================================================================|
@ -66,7 +66,13 @@ interface
uses
{$IFNDEF WIN32}
{$IFNDEF FPC}
Libc,
{$ELSE}
{$IFDEF FPC_USE_LIBC}
Libc,
{$ENDIF}
{$ENDIF}
{$ELSE}
Windows,
{$ENDIF}
@ -153,6 +159,16 @@ var
{:By this you can generally disable/enable Iconv support.}
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)}
function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar;
@ -1473,7 +1489,16 @@ end;
function GetCurCP: TMimeChar;
begin
{$IFNDEF FPC}
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;
function GetCurOEMCP: TMimeChar;
@ -1823,7 +1848,7 @@ begin
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[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].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;

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 |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -212,6 +212,9 @@ function HMAC_SHA1(Text, Key: AnsiString): AnsiString;
by repeating "value" until length is "Len".}
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
const
@ -359,14 +362,11 @@ begin
end;
type
TMD5Ctx = record
TMDCtx = record
State: array[0..3] of Integer;
Count: array[0..1] of Integer;
BufAnsiChar: array[0..63] of Byte;
BufLong: array[0..15] of Integer;
// case Integer of
// 0: (BufAnsiChar: array[0..63] of Byte);
// 1: (BufLong: array[0..15] of Integer);
end;
TSHA1Ctx= record
Hi, Lo: integer;
@ -374,11 +374,10 @@ type
Index: integer;
Hash: array[0..4] of Integer;
HashByte: array[0..19] of byte;
// case Integer of
// 0: (Hash: array[0..4] of Integer);
// 1: (HashByte: array[0..19] of byte);
end;
TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt);
{==============================================================================}
function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString;
@ -847,20 +846,20 @@ end;
{==============================================================================}
procedure MD5Init(var MD5Context: TMD5Ctx);
procedure MDInit(var MDContext: TMDCtx);
var
n: integer;
begin
MD5Context.Count[0] := 0;
MD5Context.Count[1] := 0;
for n := 0 to high(MD5Context.BufAnsiChar) do
MD5Context.BufAnsiChar[n] := 0;
for n := 0 to high(MD5Context.BufLong) do
MD5Context.BufLong[n] := 0;
MD5Context.State[0] := Integer($67452301);
MD5Context.State[1] := Integer($EFCDAB89);
MD5Context.State[2] := Integer($98BADCFE);
MD5Context.State[3] := Integer($10325476);
MDContext.Count[0] := 0;
MDContext.Count[1] := 0;
for n := 0 to high(MDContext.BufAnsiChar) do
MDContext.BufAnsiChar[n] := 0;
for n := 0 to high(MDContext.BufLong) do
MDContext.BufLong[n] := 0;
MDContext.State[0] := Integer($67452301);
MDContext.State[1] := Integer($EFCDAB89);
MDContext.State[2] := Integer($98BADCFE);
MDContext.State[3] := Integer($10325476);
end;
procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt);
@ -975,7 +974,7 @@ begin
end;
//fixed by James McAdams
procedure MD5Update(var MD5Context: TMD5Ctx; const Data: AnsiString);
procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform);
var
Index, partLen, InputLen, I: integer;
{$IFDEF CIL}
@ -983,7 +982,7 @@ var
{$ENDIF}
begin
InputLen := Length(Data);
with MD5Context do
with MDContext do
begin
Index := (Count[0] shr 3) and $3F;
Inc(Count[0], InputLen shl 3);
@ -1001,7 +1000,7 @@ begin
Move(Data[1], BufAnsiChar[Index], partLen);
{$ENDIF}
ArrByteToLong(BufAnsiChar, BufLong);
MD5Transform(State, Buflong);
Transform(State, Buflong);
I := partLen;
while I + 63 < InputLen do
begin
@ -1013,7 +1012,7 @@ begin
Move(Data[I+1], BufAnsiChar, 64);
{$ENDIF}
ArrByteToLong(BufAnsiChar, BufLong);
MD5Transform(State, Buflong);
Transform(State, Buflong);
inc(I, 64);
end;
Index := 0;
@ -1031,7 +1030,7 @@ begin
end
end;
function MD5Final(var MD5Context: TMD5Ctx): AnsiString;
function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString;
var
Cnt: Word;
P: Byte;
@ -1041,7 +1040,7 @@ var
begin
for I := 0 to 15 do
Digest[I] := I + 1;
with MD5Context do
with MDContext do
begin
Cnt := (Count[0] shr 3) and $3F;
P := Cnt;
@ -1054,7 +1053,7 @@ begin
BufAnsiChar[P + n] := 0;
ArrByteToLong(BufAnsiChar, BufLong);
// FillChar(BufAnsiChar[P], Cnt, #0);
MD5Transform(State, BufLong);
Transform(State, BufLong);
ArrLongToByte(BufLong, BufAnsiChar);
for n := 0 to 55 do
BufAnsiChar[n] := 0;
@ -1070,7 +1069,7 @@ begin
end;
BufLong[14] := Count[0];
BufLong[15] := Count[1];
MD5Transform(State, BufLong);
Transform(State, BufLong);
ArrLongToByte(State, Digest);
// Move(State, Digest, 16);
Result := '';
@ -1084,11 +1083,11 @@ end;
function MD5(const Value: AnsiString): AnsiString;
var
MD5Context: TMD5Ctx;
MDContext: TMDCtx;
begin
MD5Init(MD5Context);
MD5Update(MD5Context, Value);
Result := MD5Final(MD5Context);
MDInit(MDContext);
MDUpdate(MDContext, Value, @MD5Transform);
Result := MDFinal(MDContext, @MD5Transform);
end;
{==============================================================================}
@ -1097,7 +1096,7 @@ function HMAC_MD5(Text, Key: AnsiString): AnsiString;
var
ipad, opad, s: AnsiString;
n: Integer;
MD5Context: TMD5Ctx;
MDContext: TMDCtx;
begin
if Length(Key) > 64 then
Key := md5(Key);
@ -1108,14 +1107,14 @@ begin
ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n]));
opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n]));
end;
MD5Init(MD5Context);
MD5Update(MD5Context, ipad);
MD5Update(MD5Context, Text);
s := MD5Final(MD5Context);
MD5Init(MD5Context);
MD5Update(MD5Context, opad);
MD5Update(MD5Context, s);
Result := MD5Final(MD5Context);
MDInit(MDContext);
MDUpdate(MDContext, ipad, @MD5Transform);
MDUpdate(MDContext, Text, @MD5Transform);
s := MDFinal(MDContext, @MD5Transform);
MDInit(MDContext);
MDUpdate(MDContext, opad, @MD5Transform);
MDUpdate(MDContext, s, @MD5Transform);
Result := MDFinal(MDContext, @MD5Transform);
end;
{==============================================================================}
@ -1125,17 +1124,17 @@ var
cnt, rest: integer;
l: integer;
n: integer;
MD5Context: TMD5Ctx;
MDContext: TMDCtx;
begin
l := length(Value);
cnt := Len div l;
rest := Len mod l;
MD5Init(MD5Context);
MDInit(MDContext);
for n := 1 to cnt do
MD5Update(MD5Context, Value);
MDUpdate(MDContext, Value, @MD5Transform);
if rest > 0 then
MD5Update(MD5Context, Copy(Value, 1, rest));
Result := MD5Final(MD5Context);
MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform);
Result := MDFinal(MDContext, @MD5Transform);
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.

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 |
|==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -60,7 +60,7 @@ uses
{$IFDEF WIN32}
Windows;
{$ELSE}
Sysutils;
SysUtils;
{$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 |
|==============================================================================|
@ -64,7 +64,10 @@ uses
{$ENDIF}
synafpc,
{$IFNDEF WIN32}
Libc, SysUtils;
{$IFNDEF FPC}
Libc,
{$ENDIF}
SysUtils;
{$ELSE}
Windows;
{$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 |
|==============================================================================|
@ -218,8 +218,8 @@ var
y1, y2: byte;
begin
Result := '';
x1 := value div $10000;
x2 := value mod $10000;
x1 := value shr 16;
x2 := value and $FFFF;
y1 := x1 div $100;
y2 := x1 mod $100;
Result := inttostr(y1) + '.' + inttostr(y2) + '.';
@ -379,11 +379,18 @@ function ReverseIP6(Value: AnsiString): AnsiString;
var
ip6: TIp6bytes;
n: integer;
x, y: integer;
begin
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
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;
{==============================================================================}

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 |
|==============================================================================|
@ -302,6 +302,10 @@ procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
directory is used) and with optional filename prefix.}
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
{:can be used for your own months strings for @link(getmonthnumber)}
CustomMonthNames: array[1..12] of string;
@ -664,10 +668,15 @@ begin
end;
if year = 0 then
year := 1980;
if (month < 1) or (month > 12) then
if month < 1 then
month := 1;
if (day < 1) or (day > 31) then
if month > 12 then
month := 12;
if day < 1 then
day := 1;
x := MonthDays[IsLeapYear(year), month];
if day > x then
day := x;
Result := Result + Encodedate(year, month, day);
zone := zone - TimeZoneBias;
x := zone div 1440;
@ -1394,10 +1403,12 @@ begin
Result := False;
for n := 1 to Length(Value) do
if Value[n] in [#0..#8, #10..#31] then
begin
Result := True;
Break;
end;
//ignore null-terminated strings
if not ((n = Length(value)) and (Value[n] = #0)) then
begin
Result := True;
Break;
end;
end;
{==============================================================================}
@ -1736,6 +1747,16 @@ begin
{$ENDIF}
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
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 |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer |
| Copyright (c)1999-2007, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| 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. |
|==============================================================================|
| Contributor(s): |
@ -61,7 +61,7 @@ uses
blcksock, synautil;
const
cTelnetProtocol = 'telnet';
cTelnetProtocol = '23';
cSSHProtocol = '22';
TLNT_EOR = #239;